260 lines
9.4 KiB
Plaintext
260 lines
9.4 KiB
Plaintext
load "nat.quox"
|
||
load "either.quox"
|
||
load "maybe.quox"
|
||
load "sub.quox"
|
||
|
||
|
||
namespace nat.lt {
|
||
|
||
def0 LT : ℕ → ℕ → ★ =
|
||
elim-pair¹ (λ _ _ ⇒ ★)
|
||
False -- 0 ≮ 0
|
||
(λ n p ⇒ True) -- 0 < succ n
|
||
(λ m p ⇒ False) -- succ m ≮ 0
|
||
(λ m n p ⇒ p) -- succ m < succ n ⇔ m < n
|
||
|
||
|
||
def0 irr : sub.Irr2 ℕ ℕ LT =
|
||
elim-pair (λ m n ⇒ (p q : LT m n) → p ≡ q : LT m n)
|
||
false.irr (λ _ _ ⇒ true.irr) (λ _ _ ⇒ false.irr) (λ _ _ p ⇒ p)
|
||
|
||
|
||
-- [todo] quantities (which will need to inline and adapt elim-pair)
|
||
def elimω : 0.(P : (m n : ℕ) → LT m n → ★) →
|
||
ω.(0.(n : ℕ) → P 0 (succ n) 'true) →
|
||
ω.(0.(m n : ℕ) → 0.(lt : LT m n) →
|
||
ω.(P m n lt) → P (succ m) (succ n) lt) →
|
||
ω.(m n : ℕ) → 0.(lt : LT m n) → P m n lt =
|
||
λ P p0s pss ⇒
|
||
elim-pairω (λ m n ⇒ 0.(lt : LT m n) → P m n lt)
|
||
(λ ff ⇒ void (P 0 0 ff) ff)
|
||
(λ n p tt ⇒ p0s n)
|
||
(λ m p ff ⇒ void (P (succ m) 0 ff) ff)
|
||
(λ m n p tt ⇒ pss m n tt (p tt))
|
||
|
||
def0 true-ty : (m n : ℕ) → LT m n → LT m n ≡ True : ★ =
|
||
elim-pair¹ (λ m n ⇒ LT m n → LT m n ≡ True : ★)
|
||
(λ ff ⇒ void¹ (False ≡ True : ★) ff)
|
||
(λ n p tt ⇒ δ _ ⇒ True)
|
||
(λ m p ff ⇒ void¹ (False ≡ True : ★) ff)
|
||
(λ n m p tf ⇒ p tf)
|
||
|
||
def0 true-val :
|
||
(m n : ℕ) → (lt : LT m n) → Eq (𝑖 ⇒ true-ty m n lt @𝑖) lt 'true =
|
||
let IsTrue : (m n : ℕ) → LT m n → ★ =
|
||
λ m n lt ⇒ Eq (𝑖 ⇒ true-ty m n lt @𝑖) lt 'true in
|
||
elim-pair (λ m n ⇒ (lt : LT m n) → IsTrue m n lt)
|
||
(λ ff ⇒ void (IsTrue 0 0 ff) ff)
|
||
(λ n p tt ⇒ δ _ ⇒ 'true)
|
||
(λ m p ff ⇒ void (IsTrue (succ m) 0 ff) ff)
|
||
(λ n m p tf ⇒ p tf)
|
||
|
||
def revive : 0.(m n : ℕ) → 0.(LT m n) → LT m n =
|
||
λ m n lt ⇒ coe (𝑘 ⇒ true-ty m n lt @𝑘) @1 @0 'true
|
||
|
||
|
||
def drop : 0.(A : ★) → 0.(m n : ℕ) → LT m n → A → A =
|
||
λ A m n lt x ⇒ true.drop A (coe (𝑖 ⇒ true-ty m n lt @𝑖) lt) x
|
||
|
||
def0 succ-both : (m n : ℕ) → LT m n → LT (succ m) (succ n) =
|
||
λ m n p ⇒ p
|
||
|
||
def0 succ-right : (m n : ℕ) → LT m n → LT m (succ n) =
|
||
λ m n lt ⇒
|
||
elimω (λ m n _ ⇒ LT m (succ n))
|
||
(λ _ ⇒ 'true)
|
||
(λ _ _ _ ih ⇒ ih)
|
||
m n lt
|
||
|
||
def0 right-is-succ : (m n : ℕ) → LT m n → IsSucc n =
|
||
λ m n lt ⇒
|
||
elimω (λ _ n _ ⇒ IsSucc n) (λ _ ⇒ 'true) (λ _ _ _ _ ⇒ 'true) m n lt
|
||
|
||
def right-has-succ : 0.(m : ℕ) → (n : ℕ) → 0.(LT m n) → HasSucc n =
|
||
λ m n lt ⇒
|
||
case n return n' ⇒ 0.(LT m n') → HasSucc n' of {
|
||
0 ⇒ λ lt ⇒ void (HasSucc 0) (right-is-succ m 0 lt);
|
||
succ n ⇒ λ _ ⇒ (n, [δ _ ⇒ succ n])
|
||
} lt
|
||
|
||
def0 right-not-zero : (m : ℕ) → Not (LT m 0) =
|
||
λ m ⇒ case m return m' ⇒ Not (LT m' 0) of { 0 ⇒ λ v ⇒ v; succ _ ⇒ λ v ⇒ v }
|
||
|
||
def0 plus-right : (m n₀ n₁ : ℕ) → LT m n₀ → LT m (plus n₀ n₁) =
|
||
λ m n₀ n₁ lt ⇒
|
||
elimω (λ m n _ ⇒ LT m (plus n n₁)) (λ _ ⇒ 'true) (λ _ _ _ ih ⇒ ih) m n₀ lt
|
||
|
||
#[compile-scheme "(lambda% (m n) (if (< m n) dec.Yes dec.No))"]
|
||
def lt? : ω.(m n : ℕ) → Dec (LT m n) =
|
||
elim-pairω (λ m n ⇒ Dec (LT m n))
|
||
(No (LT 0 0) (λ v ⇒ v))
|
||
(λ n p ⇒ Yes (LT 0 (succ n)) 'true)
|
||
(λ m p ⇒ No (LT (succ m) 0) (λ v ⇒ v))
|
||
(λ m n p ⇒
|
||
dec.elim (LT m n) (λ _ ⇒ Dec (LT (succ m) (succ n)))
|
||
(λ yes ⇒ Yes (LT (succ m) (succ n)) yes)
|
||
(λ no ⇒ No (LT (succ m) (succ n)) no) p)
|
||
|
||
|
||
def0 irrefl : (m n : ℕ) → LT m n → Not (m ≡ n : ℕ) =
|
||
λ m n lt ⇒
|
||
elimω (λ m n _ ⇒ Not (m ≡ n : ℕ))
|
||
(λ n eq ⇒ zero-not-succ n eq)
|
||
(λ m n _ ih eq ⇒ ih (succ-inj m n eq))
|
||
m n lt
|
||
|
||
def0 asym : (m n : ℕ) → LT m n → Not (LT n m) =
|
||
λ m n lt ⇒
|
||
elimω (λ m n _ ⇒ Not (LT n m)) (λ _ ff ⇒ ff) (λ _ _ _ ih ff ⇒ ih ff) m n lt
|
||
|
||
def0 trans : (n₀ n₁ n₂ : ℕ) → LT n₀ n₁ → LT n₁ n₂ → LT n₀ n₂ =
|
||
λ n₀ n₁ n₂ lt₀₁ lt₁₂ ⇒
|
||
elimω (λ n₀ n₁ lt₀₁ ⇒ (n₂ : ℕ) → (lt₁₂ : LT n₁ n₂) → LT n₀ n₂)
|
||
(λ n₁ n₂ ⇒
|
||
case n₂ return n₂' ⇒ LT (succ n₁) n₂' → LT 0 n₂' of {
|
||
0 ⇒ λ v ⇒ v;
|
||
succ _ ⇒ λ _ ⇒ 'true
|
||
})
|
||
(λ n₀ n₁ lt₀₁ ih n₂ ⇒
|
||
case n₂ return n₂' ⇒ LT (succ n₁) n₂' → LT (succ n₀) n₂' of {
|
||
0 ⇒ λ v ⇒ v;
|
||
succ n₂ ⇒ λ lt₁₂ ⇒ ih n₂ lt₁₂
|
||
})
|
||
n₀ n₁ lt₀₁ n₂ lt₁₂
|
||
|
||
}
|
||
|
||
namespace nat {
|
||
def0 LT = lt.LT
|
||
def lt? = lt.lt?
|
||
}
|
||
|
||
|
||
namespace fin {
|
||
|
||
def0 Bounded : ℕ → ℕ → ★ = λ n i ⇒ nat.LT i n
|
||
|
||
def0 Fin : ℕ → ★ = λ n ⇒ Sub ℕ (Bounded n)
|
||
|
||
def fin : 0.(n : ℕ) → (i : ℕ) → 0.(Bounded n i) → Fin n =
|
||
λ n ⇒ sub.sub ℕ (Bounded n)
|
||
|
||
def val : 0.(n : ℕ) → Fin n → ℕ =
|
||
λ n ⇒ sub.val ℕ (Bounded n)
|
||
|
||
def0 val-eq : (n : ℕ) → (i j : Fin n) → val n i ≡ val n j : ℕ → i ≡ j : Fin n =
|
||
λ n ⇒ sub.sub-eq ℕ (Bounded n) (λ i ⇒ nat.lt.irr i n)
|
||
|
||
def0 proof : (n : ℕ) → (i : Fin n) → nat.LT (val n i) n =
|
||
λ n ⇒ sub.proof ℕ (Bounded n)
|
||
|
||
|
||
def0 no-fin0 : Not (Fin 0) =
|
||
λ f0 ⇒ case f0 return False of { (i, lt) ⇒
|
||
nat.lt.right-not-zero i (get0 (nat.LT i 0) lt)
|
||
}
|
||
|
||
|
||
def fin? : ω.(n i : ℕ) → Maybe (Fin n) =
|
||
λ n ⇒ sub.sub? ℕ (Bounded n) (λ i ⇒ nat.lt? i n)
|
||
|
||
def F0 : 0.(n : ℕ) → Fin (succ n) =
|
||
λ n ⇒ fin (succ n) 0 'true
|
||
def FS : 0.(n : ℕ) → Fin n → Fin (succ n) =
|
||
λ n i ⇒ fin (succ n) (succ (val n i)) (proof n i)
|
||
|
||
def weak : 0.(m n : ℕ) → 0.(nat.LT m n) → Fin m → Fin n =
|
||
λ m n mn i' ⇒
|
||
let i = val m i'; 0.im = proof m i' in
|
||
fin n i (nat.lt.trans i m n im mn)
|
||
|
||
|
||
def bound-has-succ : (n : ℕ) → 0.(Fin n) → nat.HasSucc n =
|
||
λ n i ⇒ nat.lt.right-has-succ (fst i) n (get0 (nat.LT (fst i) n) (snd i))
|
||
|
||
def elim' :
|
||
0.(P : (n i : ℕ) → nat.LT i n → ★) →
|
||
1.(pz : 0.(n : ℕ) → P (succ n) 0 'true) →
|
||
ω.(ps : 0.(n i : ℕ) → 0.(lt : nat.LT i n) →
|
||
P n i lt → P (succ n) (succ i) lt) →
|
||
0.(n : ℕ) → (i : ℕ) → 0.(lt : nat.LT i n) → P n i lt =
|
||
λ P pz ps n i lt ⇒
|
||
case i return i' ⇒ 0.(n : ℕ) → 0.(lt : nat.LT i' n) → P n i' lt of {
|
||
0 ⇒ λ n lt ⇒
|
||
let0 npp = nat.lt.right-has-succ 0 n lt;
|
||
p = nat.has-succ.val n npp;
|
||
np = nat.has-succ.proof n npp in
|
||
coe (𝑘 ⇒ P (np @𝑘) 0 (coe (𝑙 ⇒ nat.LT 0 (np @𝑙)) @0 @𝑘 lt)) @1 @0
|
||
(pz p);
|
||
succ i, ih ⇒ λ n lt ⇒
|
||
let 0.npp = nat.lt.right-has-succ (succ i) n lt;
|
||
0.p = nat.has-succ.val n npp;
|
||
0.np = nat.has-succ.proof n npp;
|
||
0.lt' : nat.LT i p = coe (𝑘 ⇒ nat.LT (succ i) (np @𝑘)) lt;
|
||
0.lteq : Eq (𝑘 ⇒ nat.LT (succ i) (np @𝑘)) lt lt' =
|
||
δ 𝑘 ⇒ coe (𝑙 ⇒ nat.LT (succ i) (np @𝑙)) @0 @𝑘 lt;
|
||
1.almost : P (succ p) (succ i) lt' = ps p i lt' (ih p lt') in
|
||
coe (𝑘 ⇒ P (np @𝑘) (succ i) (lteq @𝑘)) @1 @0 almost;
|
||
} n lt
|
||
|
||
def elim : 0.(P : (n : ℕ) → Fin n → ★) →
|
||
(pz : 0.(n : ℕ) → P (succ n) (F0 n)) →
|
||
(ps : 0.(n : ℕ) → 0.(i : Fin n) →
|
||
P n i → P (succ n) (FS n i)) →
|
||
0.(n : ℕ) → (i : Fin n) → P n i =
|
||
λ P pz ps n ilt ⇒
|
||
case ilt return ilt' ⇒ P n ilt' of { (i, lt) ⇒
|
||
let0 lt = get0 (nat.LT i n) lt in
|
||
drop0 (nat.LT i n) (P n (i, [lt])) lt
|
||
(elim' (λ n i lt ⇒ P n (i, [lt])) pz (λ n i lt ⇒ ps n (i, [lt])) n i lt)
|
||
}
|
||
|
||
{-
|
||
def elim : 0.(P : (n : ℕ) → Fin n → ★) →
|
||
(pz : 0.(n : ℕ) → P (succ n) (F0 n)) →
|
||
(ps : 0.(n : ℕ) → 0.(i : Fin n) →
|
||
P n i → P (succ n) (FS n i)) →
|
||
0.(n : ℕ) → (i : Fin n) → P n i =
|
||
λ P pz ps n ilt ⇒
|
||
let i = val n ilt; 0.lt : nat.LT i n = proof n ilt;
|
||
0.pp = nat.lt.right-has-succ i n lt;
|
||
0.p = nat.has-succ.val n pp; 0.np = nat.has-succ.proof n pp;
|
||
0.RES : ℕ → ℕ → ★ =
|
||
λ i n ⇒ (lt : nat.LT i n) × P n (i, [lt]);
|
||
res : RES i (succ p) =
|
||
case i
|
||
return i' ⇒ 0.(p : ℕ) → 0.(nat.LT i' (succ p)) → RES i' (succ p)
|
||
of {
|
||
0 ⇒ λ p _ ⇒ ('true, pz p);
|
||
succ i, IH ⇒ λ p lt ⇒
|
||
let 0.qq = nat.lt.right-has-succ i p lt;
|
||
0.q = nat.has-succ.val p qq; 0.pq = nat.has-succ.proof p qq;
|
||
0.lt : nat.LT i (succ q) = coe (𝑘 ⇒ nat.LT i (pq @𝑘)) lt;
|
||
in
|
||
case IH q lt return RES (succ i) (succ p) of { (lt', ih') ⇒
|
||
let lt : nat.LT (succ i) (succ p) =
|
||
coe (𝑘 ⇒ nat.LT i (pq @𝑘)) @1 @0 lt';
|
||
ih : P p (i, [lt]) =
|
||
coe (𝑘 ⇒ P (pq @𝑘) (i, [coe (𝑙 ⇒ nat.LT i (pq @𝑙)) @1 @𝑘 lt']))
|
||
@1 @0 ih';
|
||
res : P (succ p) (succ i, [lt]) =
|
||
ps p (i, [lt]) ih;
|
||
in
|
||
(lt, res)
|
||
}
|
||
} p (coe (𝑘 ⇒ nat.LT i (np @𝑘)) lt);
|
||
in
|
||
case coe (𝑘 ⇒ RES i (np @𝑘)) @1 @0 res
|
||
return P n ilt
|
||
of { (lt', res) ⇒
|
||
nat.lt.drop (P n ilt) i n lt' res
|
||
}
|
||
-}
|
||
|
||
}
|
||
|
||
|
||
def0 Fin = fin.Fin
|
||
def F0 = fin.F0
|
||
def FS = fin.FS
|