load "misc.quox"
load "bool.quox"
load "either.quox"
load "sub.quox"

namespace nat {

def elim-0-1 :
    0.(P : ℕ → ★) →
    ω.(P 0) → ω.(P 1) →
    ω.(0.(n : ℕ) → P n → P (succ n)) →
    (n : ℕ) → P n =
  λ P p0 p1 ps n ⇒
  case n return n' ⇒ P n' of {
    zero    ⇒ p0;
    succ n' ⇒
      case n' return n'' ⇒ P (succ n'') of {
        zero         ⇒ p1;
        succ n'', IH ⇒ ps (succ n'') IH
      }
  }

def elim-pair :
    0.(P : ℕ → ℕ → ★) →
    ω.(P 0 0) →
    ω.(0.(n : ℕ)   → P 0 n → P 0 (succ n)) →
    ω.(0.(m : ℕ)   → P m 0 → P (succ m) 0) →
    ω.(0.(m n : ℕ) → P m n → P (succ m) (succ n)) →
    (m n : ℕ) → P m n =
  λ P zz zs sz ss m ⇒
    case m return m' ⇒ (n : ℕ) → P m' n of {
      0 ⇒ λ n ⇒ case n return n' ⇒ P 0 n' of {
        0            ⇒ zz;
        succ n', ihn ⇒ zs n' ihn
      };
      succ m', ihm ⇒ λ n ⇒ case n return n' ⇒ P (succ m') n' of {
        0       ⇒ sz m' (ihm 0);
        succ n' ⇒ ss m' n' (ihm n')
      }
    }

def elim-pairω :
    0.(P : ℕ → ℕ → ★) →
    ω.(P 0 0) →
    ω.(ω.(n : ℕ)   → ω.(P 0 n) → P 0 (succ n)) →
    ω.(ω.(m : ℕ)   → ω.(P m 0) → P (succ m) 0) →
    ω.(ω.(m n : ℕ) → ω.(P m n) → P (succ m) (succ n)) →
    ω.(m n : ℕ) → P m n =
  λ P zz zs sz ss m ⇒
    caseω m return m' ⇒ ω.(n : ℕ) → P m' n of {
      0 ⇒ λ n ⇒ caseω n return n' ⇒ P 0 n' of {
        0              ⇒ zz;
        succ n', ω.ihn ⇒ zs n' ihn
      };
      succ m', ω.ihm ⇒ λ n ⇒ caseω n return n' ⇒ P (succ m') n' of {
        0       ⇒ sz m' (ihm 0);
        succ n' ⇒ ss m' n' (ihm n')
      }
    }


def succ-boxω : [ω.ℕ] → [ω.ℕ] =
  λ n ⇒ case n return [ω.ℕ] of { [n] ⇒ [succ n] }

#[compile-scheme "(lambda (n) n)"]
def dup : ℕ → [ω.ℕ] =
  λ n ⇒ case n return [ω.ℕ] of {
    0          ⇒ [0];
    succ _, n! ⇒ succ-boxω n!
  }

def0 dup-ok : (n : ℕ) → dup n ≡ [n] : [ω.ℕ] =
  λ n ⇒
  case n return n' ⇒ dup n' ≡ [n'] : [ω.ℕ] of {
    0          ⇒ δ 𝑖 ⇒ [0];
    succ _, ih ⇒ δ 𝑖 ⇒ succ-boxω (ih @𝑖)
  }

def dup! : (n : ℕ) → Dup ℕ n =
  dup.from-parts ℕ dup dup-ok


def drop : 0.(A : ★) → ℕ → A → A =
  dup.to-drop ℕ dup


def natopω' : 0.(A : ★) → ω.(ω.ℕ → ω.ℕ → A) → ℕ → ℕ → A =
  λ A f m n ⇒
    getω A (app2ω ℕ ℕ A f (dup m) (dup n))

def natopω = natopω' ℕ

#[compile-scheme "(lambda% (m n) (+ m n))"]
def plus : ℕ → ℕ → ℕ =
  λ m n ⇒
  case m return ℕ of {
    zero      ⇒ n;
    succ _, p ⇒ succ p
  }

#[compile-scheme "(lambda% (m n) (* m n))"]
def timesω : ω.ℕ → ω.ℕ → ℕ =
  λ m n ⇒
  case m return ℕ of {
    zero      ⇒ zero;
    succ _, t ⇒ plus n t
  }

def times = natopω timesω

def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n }

def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ =
  λ n ⇒ δ 𝑖 ⇒ n

def succ-inj : 0.(m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ =
  λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖)

#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
def minus : ℕ → ℕ → ℕ =
  λ m n ⇒
  (case n return ℕ → ℕ of {
    zero      ⇒ λ m ⇒ m;
    succ _, f ⇒ λ m ⇒ f (pred m)
  }) m


def minω : ω.ℕ → ω.ℕ → ℕ =
  elim-pairω (λ _ _ ⇒ ℕ) 0 (λ _ _ ⇒ 0) (λ _ _ ⇒ 0) (λ _ _ x ⇒ succ x)

def min = natopω minω


def0 IsSucc : ℕ → ★ =
  λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True }

def is-succ? : ω.(n : ℕ) → Dec (IsSucc n) =
  λ n ⇒
  caseω n return n' ⇒ Dec (IsSucc n') of {
    zero   ⇒ No  (IsSucc zero)      (λ v ⇒ v);
    succ n ⇒ Yes (IsSucc (succ n)) 'true
  }

def zero-not-succ : 0.(m : ℕ) → Not (zero ≡ succ m : ℕ) =
  λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) @1 @0 'true

def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) =
  λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true

def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) =
  λ m ⇒
  case m return m' ⇒ Not (m' ≡ succ m' : ℕ) of {
    zero         ⇒ zero-not-succ 0;
    succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq)
  }


def0 IsSuccOf : ℕ → ℕ → ★ =
  λ n p ⇒ n ≡ succ p : ℕ

def0 PredOf : ℕ → ★ =
  λ n ⇒ Sub ℕ (IsSuccOf n)

def0 no-pred0 : Not (PredOf 0) =
  λ p ⇒
  case p return False of { (p, lt) ⇒
    zero-not-succ p (get0 (0 ≡ succ p : ℕ) lt)
  }

def pred? : (n : ℕ) → DecT (PredOf n) =
  λ n ⇒
  case n return n' ⇒ DecT (PredOf n') of {
    zero   ⇒ NoT  (PredOf zero)     no-pred0;
    succ n ⇒ YesT (PredOf (succ n)) (n, [δ _ ⇒ succ n])
  }

namespace pred-of {

def revive : (n : ℕ) → 0.(PredOf n) → PredOf n =
  λ n hs ⇒
    let0 p = fst hs in
    case n return n' ⇒ 0.(n' ≡ succ p : ℕ) → PredOf n' of {
      zero    ⇒ λ eq ⇒ void (PredOf zero) (zero-not-succ p eq);
      succ p' ⇒ λ _  ⇒ (p', [δ _ ⇒ succ p'])
    } (get0 (n ≡ succ p : ℕ) (snd hs))

def val : 0.(n : ℕ) → PredOf n → ℕ =
  λ n ⇒ sub.val ℕ (IsSuccOf n)

def0 proof : (n : ℕ) → (p : PredOf n) → n ≡ succ (fst p) : ℕ =
  λ n ⇒ sub.proof ℕ (IsSuccOf n)

}


def divmodω : ω.ℕ → ω.ℕ → ℕ × ℕ =
  -- https://coq.inria.fr/doc/V8.18.0/stdlib/Coq.Init.Nat.html#divmod
  letω divmod' : ℕ → ω.ℕ → ℕ → ℕ → ℕ × ℕ =
    λ x ⇒
    case x return ω.ℕ → ℕ → ℕ → ℕ × ℕ of {
      0          ⇒ λ y q u ⇒ (q, u);
      succ _, f' ⇒ λ y q u ⇒
        case u return ℕ × ℕ of {
          0       ⇒ f' y (succ q) y;
          succ u' ⇒ f' y q u'
        }
    } in
  λ x y ⇒
  caseω y return ℕ × ℕ of {
    0       ⇒ (0, 0);
    succ y' ⇒
      case divmod' x y' 0 y' return ℕ × ℕ of { (d, m) ⇒ (d, minus y' m) }
  }

def divmod = natopω' (ℕ × ℕ) divmodω

def divω : ω.ℕ → ω.ℕ → ℕ = λ x y ⇒ fst (divmodω x y)
def div = natopω divω

def modω : ω.ℕ → ω.ℕ → ℕ = λ x y ⇒ snd (divmodω x y)
def mod = natopω modω


#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"]
def eq? : DecEq ℕ =
  λ m n ⇒
  elim-pair (λ m n ⇒ Dec (m ≡ n : ℕ))
    (Yes (0 ≡ 0 : ℕ) (δ 𝑖 ⇒ 0))
    (λ n p ⇒
      dec.drop (0 ≡ n : ℕ) (Dec (0 ≡ succ n : ℕ)) p
        (No (0 ≡ succ n : ℕ) (λ zs ⇒ zero-not-succ n zs)))
    (λ m p ⇒
      dec.drop (m ≡ 0 : ℕ) (Dec (succ m ≡ 0 : ℕ)) p
        (No (succ m ≡ 0 : ℕ) (λ sz ⇒ succ-not-zero m sz)))
    (λ m n ⇒
      dec.elim (m ≡ n : ℕ) (λ _ ⇒ Dec (succ m ≡ succ n : ℕ))
        (λ yy ⇒ Yes (succ m ≡ succ n : ℕ) (δ 𝑖  ⇒ succ (yy @𝑖)))
        (λ nn ⇒ No  (succ m ≡ succ n : ℕ) (λ yy ⇒ nn (succ-inj m n yy))))
    m n


def0 Ordering : ★ = {lt, eq, gt}

namespace ordering {
  def from : 0.(A : ★) → ω.A → ω.A → ω.A → Ordering → A =
    λ A lt eq gt o ⇒
    case o return A of { 'lt ⇒ lt; 'eq ⇒ eq; 'gt ⇒ gt }

  def drop : 0.(A : ★) → Ordering → A → A =
    λ A o x ⇒ case o return A of { 'lt ⇒ x; 'eq ⇒ x; 'gt ⇒ x }

  def eq : Ordering → Ordering → Bool =
    λ x y ⇒
    case x return Bool of {
      'lt ⇒ case y return Bool of { 'lt ⇒ 'true;  'eq ⇒ 'false; 'gt ⇒ 'false };
      'eq ⇒ case y return Bool of { 'lt ⇒ 'false; 'eq ⇒ 'true;  'gt ⇒ 'false };
      'gt ⇒ case y return Bool of { 'lt ⇒ 'false; 'eq ⇒ 'false; 'gt ⇒ 'true  };
    }
}

def compare : ℕ → ℕ → Ordering =
  elim-pair (λ _ _ ⇒ Ordering)
    'eq
    (λ _ o   ⇒ ordering.drop Ordering o 'lt)
    (λ _ o   ⇒ ordering.drop Ordering o 'gt)
    (λ _ _ x ⇒ x)

def lt : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ ordering.eq (compare m n) 'lt
def eq : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ ordering.eq (compare m n) 'eq
def gt : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ ordering.eq (compare m n) 'gt
def ne : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ bool.not (eq m n)
def le : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ bool.not (gt m n)
def ge : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ bool.not (lt m n)


def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ =
  λ m ⇒
  case m return m' ⇒ m' ≡ plus m' 0 : ℕ of {
    zero        ⇒ δ _ ⇒ 0;
    succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
  }

def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ =
  λ m n ⇒
  case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of {
    zero       ⇒ δ _ ⇒ succ n;
    succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖)
  }

def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ =
  λ m ⇒
  case m return m' ⇒ 0 ≡ timesω m' 0 : ℕ of {
    zero        ⇒ δ _ ⇒ zero;
    succ m', ih ⇒ ih
  }

}