596 lines
22 KiB
Plaintext
596 lines
22 KiB
Plaintext
load "misc.quox"
|
||
load "nat.quox"
|
||
load "maybe.quox"
|
||
load "bool.quox"
|
||
load "qty.quox"
|
||
|
||
namespace vec {
|
||
|
||
def0 Vec : ℕ → ★ → ★ =
|
||
λ n A ⇒
|
||
caseω n return ★ of {
|
||
zero ⇒ {nil};
|
||
succ _, 0.Tail ⇒ A × Tail
|
||
}
|
||
|
||
def drop-nil-dep : 0.(A : ★) → 0.(P : Vec 0 A → ★) →
|
||
(xs : Vec 0 A) → P 'nil → P xs =
|
||
λ A P xs p ⇒ case xs return xs' ⇒ P xs' of { 'nil ⇒ p }
|
||
|
||
def drop-nil : 0.(A B : ★) → Vec 0 A → B → B =
|
||
λ A B ⇒ drop-nil-dep A (λ _ ⇒ B)
|
||
|
||
def match-dep :
|
||
0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||
ω.(P 0 'nil) →
|
||
ω.((n : ℕ) → (x : A) → (xs : Vec n A) → P (succ n) (x, xs)) →
|
||
(n : ℕ) → (xs : Vec n A) → P n xs =
|
||
λ A P pn pc n ⇒
|
||
case n return n' ⇒ (xs : Vec n' A) → P n' xs of {
|
||
0 ⇒ λ nil ⇒ drop-nil-dep A (P 0) nil pn;
|
||
succ len ⇒ λ cons ⇒
|
||
case cons return cons' ⇒ P (succ len) cons' of {
|
||
(first, rest) ⇒ pc len first rest
|
||
}
|
||
}
|
||
|
||
def match-depω :
|
||
0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||
ω.(P 0 'nil) →
|
||
ω.(ω.(n : ℕ) → ω.(x : A) → ω.(xs : Vec n A) → P (succ n) (x, xs)) →
|
||
ω.(n : ℕ) → ω.(xs : Vec n A) → P n xs =
|
||
λ A P pn pc n ⇒
|
||
caseω n return n' ⇒ ω.(xs : Vec n' A) → P n' xs of {
|
||
0 ⇒ λ nil ⇒ drop-nil-dep A (P 0) nil pn;
|
||
succ len ⇒ λ cons ⇒
|
||
caseω cons return cons' ⇒ P (succ len) cons' of {
|
||
(first, rest) ⇒ pc len first rest
|
||
}
|
||
}
|
||
def match-dep# = match-depω
|
||
|
||
def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||
P 0 'nil →
|
||
ω.((x : A) → 0.(n : ℕ) → 0.(xs : Vec n A) →
|
||
P n xs → P (succ n) (x, xs)) →
|
||
(n : ℕ) → (xs : Vec n A) → P n xs =
|
||
λ A P pn pc n ⇒
|
||
case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of {
|
||
zero ⇒ λ nil ⇒
|
||
case nil return nil' ⇒ P 0 nil' of { 'nil ⇒ pn };
|
||
succ n, IH ⇒ λ cons ⇒
|
||
case cons return cons' ⇒ P (succ n) cons' of {
|
||
(first, rest) ⇒ pc first n rest (IH rest)
|
||
}
|
||
}
|
||
|
||
def elim2 : 0.(A B : ★) → 0.(P : (n : ℕ) → Vec n A → Vec n B → ★) →
|
||
P 0 'nil 'nil →
|
||
ω.((x : A) → (y : B) → 0.(n : ℕ) →
|
||
0.(xs : Vec n A) → 0.(ys : Vec n B) →
|
||
P n xs ys → P (succ n) (x, xs) (y, ys)) →
|
||
(n : ℕ) → (xs : Vec n A) → (ys : Vec n B) → P n xs ys =
|
||
λ A B P pn pc n ⇒
|
||
case n return n' ⇒ (xs : Vec n' A) → (ys : Vec n' B) → P n' xs ys of {
|
||
zero ⇒ λ nila nilb ⇒
|
||
drop-nil-dep A (λ n ⇒ P 0 n nilb) nila
|
||
(drop-nil-dep B (λ n ⇒ P 0 'nil n) nilb pn);
|
||
succ n, IH ⇒ λ consa consb ⇒
|
||
case consa return consa' ⇒ P (succ n) consa' consb of { (a, as) ⇒
|
||
case consb return consb' ⇒ P (succ n) (a, as) consb' of { (b, bs) ⇒
|
||
pc a b n as bs (IH as bs)
|
||
}
|
||
}
|
||
}
|
||
|
||
def elim2-uneven :
|
||
0.(A B : ★) → 0.(P : (m n : ℕ) → Vec m A → Vec n B → ★) →
|
||
-- both nil
|
||
ω.(P 0 0 'nil 'nil) →
|
||
-- first nil
|
||
ω.((y : B) → 0.(n : ℕ) → 0.(ys : Vec n B) →
|
||
P 0 n 'nil ys → P 0 (succ n) 'nil (y, ys)) →
|
||
-- second nil
|
||
ω.((x : A) → 0.(m : ℕ) → 0.(xs : Vec m A) →
|
||
P m 0 xs 'nil → P (succ m) 0 (x, xs) 'nil) →
|
||
-- both cons
|
||
ω.((x : A) → (y : B) → 0.(m n : ℕ) →
|
||
0.(xs : Vec m A) → 0.(ys : Vec n B) →
|
||
P m n xs ys → P (succ m) (succ n) (x, xs) (y, ys)) →
|
||
(m n : ℕ) → (xs : Vec m A) → (ys : Vec n B) → P m n xs ys =
|
||
λ A B P pnn pnc pcn pcc ⇒
|
||
nat.elim-pair (λ m n ⇒ (xs : Vec m A) → (ys : Vec n B) → P m n xs ys)
|
||
(λ xnil ynil ⇒
|
||
let0 Ret = P 0 0 'nil 'nil in
|
||
drop-nil A Ret xnil (drop-nil B Ret ynil pnn))
|
||
(λ n IH xnil yys ⇒
|
||
case yys return yys' ⇒ P 0 (succ n) 'nil yys' of { (y, ys) ⇒
|
||
pnc y n ys (IH xnil ys)
|
||
})
|
||
(λ m IH xxs ynil ⇒
|
||
case xxs return xxs' ⇒ P (succ m) 0 xxs' 'nil of { (x, xs) ⇒
|
||
pcn x m xs (IH xs ynil)
|
||
})
|
||
(λ m n IH xxs yys ⇒
|
||
case xxs return xxs' ⇒ P (succ m) (succ n) xxs' yys of { (x, xs) ⇒
|
||
case yys return yys' ⇒ P (succ m) (succ n) (x, xs) yys' of { (y, ys) ⇒
|
||
pcc x y m n xs ys (IH xs ys)
|
||
}})
|
||
|
||
-- haha gross
|
||
def elimω : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||
ω.(P 0 'nil) →
|
||
ω.(ω.(x : A) → ω.(n : ℕ) → ω.(xs : Vec n A) →
|
||
ω.(P n xs) → P (succ n) (x, xs)) →
|
||
ω.(n : ℕ) → ω.(xs : Vec n A) → P n xs =
|
||
λ A P pn pc n ⇒
|
||
caseω n return n' ⇒ ω.(xs' : Vec n' A) → P n' xs' of {
|
||
zero ⇒ λ _ ⇒ pn;
|
||
succ n, ω.IH ⇒ λ xxs ⇒
|
||
letω x = fst xxs; xs = snd xxs in pc x n xs (IH xs)
|
||
}
|
||
|
||
def elimω2 : 0.(A B : ★) → 0.(P : (n : ℕ) → Vec n A → Vec n B → ★) →
|
||
ω.(P 0 'nil 'nil) →
|
||
ω.(ω.(x : A) → ω.(y : B) → ω.(n : ℕ) →
|
||
ω.(xs : Vec n A) → ω.(ys : Vec n B) →
|
||
ω.(P n xs ys) → P (succ n) (x, xs) (y, ys)) →
|
||
ω.(n : ℕ) → ω.(xs : Vec n A) → ω.(ys : Vec n B) → P n xs ys =
|
||
λ A B P pn pc n ⇒
|
||
caseω n return n' ⇒ ω.(xs : Vec n' A) → ω.(ys : Vec n' B) → P n' xs ys of {
|
||
zero ⇒ λ _ _ ⇒ pn;
|
||
succ n, ω.IH ⇒ λ xxs yys ⇒
|
||
letω x = fst xxs; xs = snd xxs; y = fst yys; ys = snd yys in
|
||
pc x y n xs ys (IH xs ys)
|
||
}
|
||
|
||
{-
|
||
postulate elimP :
|
||
ω.(π : NzQty) → ω.(ρₙ ρₗ : Qty) →
|
||
0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) →
|
||
FunNz π (P 0 'nil)
|
||
(Fun 'any
|
||
(FUN-NZ π A (λ x ⇒ FUN ρₙ ℕ (λ n ⇒ FUN ρₗ (Vec n A) (λ xs ⇒
|
||
FunNz π (P n xs) (P (succ n) (x, xs))))))
|
||
(FUN-NZ π ℕ (λ n ⇒ FUN-NZ π (Vec n A) (λ xs ⇒ P n xs))))
|
||
{-
|
||
=
|
||
λ π ρₙ ρₗ A P ⇒ uhhhhhhhhhhhhhhhhhhh
|
||
-}
|
||
-}
|
||
|
||
def elimω2-uneven :
|
||
0.(A B : ★) → 0.(P : (m n : ℕ) → Vec m A → Vec n B → ★) →
|
||
-- both nil
|
||
ω.(P 0 0 'nil 'nil) →
|
||
-- first nil
|
||
ω.(ω.(y : B) → ω.(n : ℕ) → ω.(ys : Vec n B) →
|
||
ω.(P 0 n 'nil ys) → P 0 (succ n) 'nil (y, ys)) →
|
||
-- second nil
|
||
ω.(ω.(x : A) → ω.(m : ℕ) → ω.(xs : Vec m A) →
|
||
ω.(P m 0 xs 'nil) → P (succ m) 0 (x, xs) 'nil) →
|
||
-- both cons
|
||
ω.(ω.(x : A) → ω.(y : B) → ω.(m n : ℕ) →
|
||
ω.(xs : Vec m A) → ω.(ys : Vec n B) →
|
||
ω.(P m n xs ys) → P (succ m) (succ n) (x, xs) (y, ys)) →
|
||
ω.(m n : ℕ) → ω.(xs : Vec m A) → ω.(ys : Vec n B) → P m n xs ys =
|
||
λ A B P pnn pnc pcn pcc ⇒
|
||
nat.elim-pairω (λ m n ⇒ ω.(xs : Vec m A) → ω.(ys : Vec n B) → P m n xs ys)
|
||
(λ _ _ ⇒ pnn)
|
||
(λ n IH xnil yys ⇒
|
||
letω y = fst yys; ys = snd yys in pnc y n ys (IH xnil ys))
|
||
(λ m IH xxs ynil ⇒
|
||
letω x = fst xxs; xs = snd xxs in pcn x m xs (IH xs ynil))
|
||
(λ m n IH xxs yys ⇒
|
||
letω x = fst xxs; xs = snd xxs; y = fst yys; ys = snd yys in
|
||
pcc x y m n xs ys (IH xs ys))
|
||
|
||
def zip-with : 0.(A B C : ★) → ω.(A → B → C) →
|
||
(n : ℕ) → Vec n A → Vec n B → Vec n C =
|
||
λ A B C f ⇒
|
||
elim2 A B (λ n _ _ ⇒ Vec n C) 'nil (λ a b _ _ _ abs ⇒ (f a b, abs))
|
||
|
||
def zip-withω : 0.(A B C : ★) → ω.(ω.A → ω.B → C) →
|
||
ω.(n : ℕ) → ω.(Vec n A) → ω.(Vec n B) → Vec n C =
|
||
λ A B C f ⇒
|
||
elimω2 A B (λ n _ _ ⇒ Vec n C) 'nil (λ a b _ _ _ abs ⇒ (f a b, abs))
|
||
|
||
|
||
namespace zip-with {
|
||
def0 Failure : (A B : ★) → (m n : ℕ) → Vec m A → Vec n B → ★ =
|
||
λ A B m n xs ys ⇒
|
||
Sing (Vec m A) xs × Sing (Vec n B) ys × [0. Not (m ≡ n : ℕ)]
|
||
|
||
def0 Success : (C : ★) → (m n : ℕ) → ★ =
|
||
λ C m n ⇒ Vec n C × [0. m ≡ n : ℕ]
|
||
|
||
def0 Result : (A B C : ★) → (m n : ℕ) → Vec m A → Vec n B → ★ =
|
||
λ A B C m n xs ys ⇒
|
||
Either (Failure A B m n xs ys) (Success C m n)
|
||
|
||
def zip-with-hetω : 0.(A B C : ★) → ω.(A → B → C) →
|
||
ω.(m n : ℕ) → (xs : Vec m A) → (ys : Vec n B) →
|
||
Result A B C m n xs ys =
|
||
λ A B C f m n xs ys ⇒
|
||
let0 TNo : Vec m A → Vec n B → ★ = Failure A B m n;
|
||
TYes : ★ = Success C m n;
|
||
TRes : Vec m A → Vec n B → ★ = λ xs ys ⇒ Either (TNo xs ys) TYes in
|
||
dec.elim (m ≡ n : ℕ)
|
||
(λ _ ⇒ (xs : Vec m A) → (ys : Vec n B) → TRes xs ys)
|
||
(λ eq xs ys ⇒
|
||
let zs : Vec n C =
|
||
zip-with A B C f n (coe (𝑖 ⇒ Vec (eq @𝑖) A) xs) ys in
|
||
Right (TNo xs ys) TYes (zs, [eq]))
|
||
(λ neq xs ys ⇒ Left (TNo xs ys) TYes
|
||
(sing (Vec m A) xs, sing (Vec n B) ys, [neq]))
|
||
(nat.eq? m n) xs ys
|
||
|
||
def zip-with-het : 0.(A B C : ★) → ω.(A → B → C) →
|
||
(m n : ℕ) → (xs : Vec m A) → (ys : Vec n B) →
|
||
Result A B C m n xs ys =
|
||
λ A B C f m n ⇒
|
||
let0 Ret : ℕ → ℕ → ★ =
|
||
λ m n ⇒ (xs : Vec m A) → (ys : Vec n B) → Result A B C m n xs ys in
|
||
dup.elim ℕ m (λ m' ⇒ Ret m' n)
|
||
(λ m ⇒ dup.elim ℕ n (λ n' ⇒ Ret m n')
|
||
(λ n ⇒ zip-with-hetω A B C f m n) (nat.dup! n))
|
||
(nat.dup! m)
|
||
}
|
||
def0 ZipWith = zip-with.Result
|
||
def zip-with-het = zip-with.zip-with-het
|
||
def zip-with-hetω = zip-with.zip-with-hetω
|
||
|
||
def map : 0.(A B : ★) → ω.(A → B) → (n : ℕ) → Vec n A → Vec n B =
|
||
λ A B f ⇒ elim A (λ n _ ⇒ Vec n B) 'nil (λ x _ _ ys ⇒ (f x, ys))
|
||
|
||
#[compile-scheme "(lambda% (n xs) xs)"]
|
||
def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A =
|
||
λ A n ⇒
|
||
case n return n' ⇒ Vec n' A → Vec¹ n' A of {
|
||
zero ⇒ λ xs ⇒
|
||
case xs return Vec¹ 0 A of { 'nil ⇒ 'nil };
|
||
succ n', f' ⇒ λ xs ⇒
|
||
case xs return Vec¹ (succ n') A of {
|
||
(first, rest) ⇒ (first, f' rest)
|
||
}
|
||
}
|
||
|
||
def append : 0.(A : ★) → (m : ℕ) → 0.(n : ℕ) →
|
||
Vec m A → Vec n A → Vec (nat.plus m n) A =
|
||
λ A m n xs ys ⇒
|
||
elim A (λ m _ ⇒ Vec (nat.plus m n) A) ys (λ x _ _ xsys ⇒ (x, xsys)) m xs
|
||
|
||
}
|
||
|
||
def0 Vec = vec.Vec
|
||
|
||
|
||
namespace list {
|
||
|
||
def0 List : ★ → ★ =
|
||
λ A ⇒ (len : ℕ) × Vec len A
|
||
|
||
def Nil : 0.(A : ★) → List A =
|
||
λ A ⇒ (0, 'nil)
|
||
|
||
def Cons : 0.(A : ★) → A → List A → List A =
|
||
λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) }
|
||
|
||
def single : 0.(A : ★) → A → List A =
|
||
λ A x ⇒ Cons A x (Nil A)
|
||
|
||
def elim : 0.(A : ★) → 0.(P : List A → ★) →
|
||
P (Nil A) →
|
||
ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) →
|
||
(xs : List A) → P xs =
|
||
λ A P pn pc xs ⇒
|
||
case xs return xs' ⇒ P xs' of { (len, elems) ⇒
|
||
vec.elim A (λ n xs ⇒ P (n, xs))
|
||
pn (λ x n xs IH ⇒ pc x (n, xs) IH)
|
||
len elems
|
||
}
|
||
|
||
def elimω : 0.(A : ★) → 0.(P : List A → ★) →
|
||
ω.(P (Nil A)) →
|
||
ω.(ω.(x : A) → ω.(xs : List A) → ω.(P xs) → P (Cons A x xs)) →
|
||
ω.(xs : List A) → P xs =
|
||
λ A P pn pc xs ⇒
|
||
caseω xs return xs' ⇒ P xs' of { (len, elems) ⇒
|
||
vec.elimω A (λ n xs ⇒ P (n, xs))
|
||
pn (λ x n xs IH ⇒ pc x (n, xs) IH)
|
||
len elems
|
||
}
|
||
|
||
def elim2 : 0.(A B : ★) → 0.(P : List A → List B → ★) →
|
||
ω.(P (Nil A) (Nil B)) →
|
||
ω.((y : B) → 0.(ys : List B) →
|
||
P (Nil A) ys → P (Nil A) (Cons B y ys)) →
|
||
ω.((x : A) → 0.(xs : List A) →
|
||
P xs (Nil B) → P (Cons A x xs) (Nil B)) →
|
||
ω.((x : A) → 0.(xs : List A) → (y : B) → 0.(ys : List B) →
|
||
P xs ys → P (Cons A x xs) (Cons B y ys)) →
|
||
(xs : List A) → (ys : List B) → P xs ys =
|
||
λ A B P pnn pnc pcn pcc xs ys ⇒
|
||
case xs return xs' ⇒ P xs' ys of { (m, xs) ⇒
|
||
case ys return ys' ⇒ P (m, xs) ys' of { (n, ys) ⇒
|
||
vec.elim2-uneven A B (λ m n xs ys ⇒ P (m, xs) (n, ys))
|
||
pnn
|
||
(λ y n ys IH ⇒ pnc y (n, ys) IH)
|
||
(λ x m xs IH ⇒ pcn x (m, xs) IH)
|
||
(λ x y m n xs ys IH ⇒ pcc x (m, xs) y (n, ys) IH)
|
||
m n xs ys
|
||
}}
|
||
|
||
def elimω2 : 0.(A B : ★) → 0.(P : List A → List B → ★) →
|
||
ω.(P (Nil A) (Nil B)) →
|
||
ω.(ω.(y : B) → ω.(ys : List B) →
|
||
ω.(P (Nil A) ys) → P (Nil A) (Cons B y ys)) →
|
||
ω.(ω.(x : A) → ω.(xs : List A) →
|
||
ω.(P xs (Nil B)) → P (Cons A x xs) (Nil B)) →
|
||
ω.(ω.(x : A) → ω.(xs : List A) → ω.(y : B) → ω.(ys : List B) →
|
||
ω.(P xs ys) → P (Cons A x xs) (Cons B y ys)) →
|
||
ω.(xs : List A) → ω.(ys : List B) → P xs ys =
|
||
λ A B P pnn pnc pcn pcc xs ys ⇒
|
||
caseω xs return xs' ⇒ P xs' ys of { (m, xs) ⇒
|
||
caseω ys return ys' ⇒ P (m, xs) ys' of { (n, ys) ⇒
|
||
vec.elimω2-uneven A B (λ m n xs ys ⇒ P (m, xs) (n, ys))
|
||
pnn
|
||
(λ y n ys IH ⇒ pnc y (n, ys) IH)
|
||
(λ x m xs IH ⇒ pcn x (m, xs) IH)
|
||
(λ x y m n xs ys IH ⇒ pcc x (m, xs) y (n, ys) IH)
|
||
m n xs ys
|
||
}}
|
||
|
||
def as-vec : 0.(A : ★) → 0.(P : List A → ★) → (xs : List A) →
|
||
(ω.(n : ℕ) → (xs : Vec n A) → P (n, xs)) → P xs =
|
||
λ A P xs f ⇒
|
||
case xs return xs' ⇒ P xs' of { (n, xs) ⇒
|
||
dup.elim ℕ n (λ n' ⇒ (xs : Vec n' A) → P (n', xs)) f (nat.dup! n) xs
|
||
}
|
||
|
||
def match-dep :
|
||
0.(A : ★) → 0.(P : List A → ★) →
|
||
ω.(P (Nil A)) → ω.((x : A) → (xs : List A) → P (Cons A x xs)) →
|
||
(xs : List A) → P xs =
|
||
λ A P pn pc xs ⇒
|
||
case xs return xs' ⇒ P xs' of {
|
||
(len, elems) ⇒
|
||
vec.match-dep A (λ n xs ⇒ P (n, xs)) pn (λ n x xs ⇒ pc x (n, xs))
|
||
len elems
|
||
}
|
||
|
||
def match-depω :
|
||
0.(A : ★) → 0.(P : List A → ★) →
|
||
ω.(P (Nil A)) →
|
||
ω.(ω.(x : A) → ω.(xs : List A) → P (Cons A x xs)) →
|
||
ω.(xs : List A) → P xs =
|
||
λ A P pn pc xs ⇒
|
||
vec.match-depω A (λ n xs ⇒ P (n, xs)) pn (λ n x xs ⇒ pc x (n, xs))
|
||
(fst xs) (snd xs)
|
||
def match-dep# = match-depω
|
||
|
||
def match : 0.(A B : ★) → ω.B → ω.(A → List A → B) → List A → B =
|
||
λ A B ⇒ match-dep A (λ _ ⇒ B)
|
||
|
||
def matchω : 0.(A B : ★) → ω.B → ω.(ω.A → ω.(List A) → B) → ω.(List A) → B =
|
||
λ A B ⇒ match-depω A (λ _ ⇒ B)
|
||
def match# = matchω
|
||
|
||
|
||
def up : 0.(A : ★) → List A → List¹ A =
|
||
λ A xs ⇒
|
||
case xs return List¹ A of { (len, elems) ⇒
|
||
dup.elim'¹ ℕ len (λ _ ⇒ List¹ A)
|
||
(λ len eq ⇒ (len, vec.up A len (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems)))
|
||
(nat.dup! len)
|
||
}
|
||
|
||
def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
|
||
λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs
|
||
|
||
def foldl : 0.(A B : ★) → B → ω.(B → A → B) → List A → B =
|
||
λ A B z f xs ⇒
|
||
foldr A (B → B) (λ b ⇒ b) (λ a g b ⇒ g (f b a)) xs z
|
||
|
||
def map : 0.(A B : ★) → ω.(A → B) → List A → List B =
|
||
λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys)
|
||
|
||
|
||
-- ugh
|
||
def foldrω : 0.(A B : ★) → ω.B → ω.(ω.A → ω.B → B) → ω.(List A) → B =
|
||
λ A B z f xs ⇒ elimω A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs
|
||
|
||
def foldlω : 0.(A B : ★) → ω.B → ω.(ω.B → ω.A → B) → ω.(List A) → B =
|
||
λ A B z f xs ⇒
|
||
foldrω A (ω.B → B) (λ b ⇒ b) (λ a g b ⇒ g (f b a)) xs z
|
||
|
||
def mapω : 0.(A B : ★) → ω.(ω.A → B) → ω.(List A) → List B =
|
||
λ A B f ⇒ foldrω A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys)
|
||
|
||
|
||
def0 All : (A : ★) → (P : A → ★) → List A → ★ =
|
||
λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs)
|
||
|
||
def append : 0.(A : ★) → List A → List A → List A =
|
||
λ A xs ys ⇒ foldr A (List A) ys (Cons A) xs
|
||
|
||
def reverse : 0.(A : ★) → List A → List A =
|
||
λ A ⇒ foldl A (List A) (Nil A) (λ xs x ⇒ Cons A x xs)
|
||
|
||
|
||
def find : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → Maybe A =
|
||
λ A p ⇒
|
||
foldlω A (Maybe A) (Nothing A) (λ m x ⇒ maybe.or A m (maybe.check A p x))
|
||
|
||
def cons-first : 0.(A : ★) → ω.A → List (List A) → List (List A) =
|
||
λ A x ⇒
|
||
match (List A) (List (List A))
|
||
(single (List A) (single A x))
|
||
(λ xs xss ⇒ Cons (List A) (Cons A x xs) xss)
|
||
|
||
def split : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → List (List A) =
|
||
λ A p ⇒
|
||
foldrω A (List (List A))
|
||
(Nil (List A))
|
||
(λ x xss ⇒ bool.if (List (List A)) (p x)
|
||
(Cons (List A) (Nil A) xss)
|
||
(cons-first A x xss))
|
||
|
||
def break : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → List A × List A =
|
||
λ A p xs ⇒
|
||
let0 Lst = List A; Lst2 = (Lst × Lst) ∷ ★; State = Either Lst Lst2 in
|
||
letω LeftS = Left Lst Lst2; RightS = Right Lst Lst2 in
|
||
letω res =
|
||
foldlω A State
|
||
(LeftS (Nil A))
|
||
(λ acc x ⇒
|
||
either.foldω Lst Lst2 State
|
||
(λ xs ⇒ bool.if State (p x)
|
||
(RightS (xs, list.single A x))
|
||
(LeftS (Cons A x xs)))
|
||
(λ xsys ⇒
|
||
RightS (fst xsys, Cons A x (snd xsys))) acc)
|
||
xs ∷ State in
|
||
letω res =
|
||
either.fold Lst Lst2 Lst2 (λ xs ⇒ (Nil A, xs)) (λ xsys ⇒ xsys) res in
|
||
(reverse A (fst res), reverse A (snd res))
|
||
|
||
def uncons : 0.(A : ★) → List A → Maybe (A × List A) =
|
||
λ A ⇒
|
||
match A (Maybe (A × List A))
|
||
(Nothing (A × List A))
|
||
(λ x xs ⇒ Just (A × List A) (x, xs))
|
||
|
||
def head : 0.(A : ★) → ω.(List A) → Maybe A =
|
||
λ A ⇒ matchω A (Maybe A) (Nothing A) (λ x _ ⇒ Just A x)
|
||
|
||
def tail : 0.(A : ★) → ω.(List A) → Maybe (List A) =
|
||
λ A ⇒ matchω A (Maybe (List A)) (Nothing (List A)) (λ _ xs ⇒ Just (List A) xs)
|
||
|
||
def tail-or-nil : 0.(A : ★) → ω.(List A) → List A =
|
||
λ A ⇒ matchω A (List A) (Nil A) (λ _ xs ⇒ xs)
|
||
|
||
-- slip (xs, []) = (xs, [])
|
||
-- slip (xs, y :: ys) = (y :: xs, ys)
|
||
def slip : 0.(A : ★) → List A × List A → List A × List A =
|
||
λ A xsys ⇒
|
||
case xsys return List A × List A of { (xs, ys) ⇒
|
||
match A (List A → List A × List A)
|
||
(λ xs ⇒ (xs, Nil A))
|
||
(λ y ys xs ⇒ (Cons A y xs, ys))
|
||
ys xs
|
||
}
|
||
|
||
def split-at' : 0.(A : ★) → ℕ → List A → List A × List A =
|
||
λ A n xs ⇒
|
||
(case n return List A × List A → List A × List A of {
|
||
0 ⇒ λ xsys ⇒ xsys;
|
||
succ _, f ⇒ λ xsys ⇒ f (slip A xsys)
|
||
}) (Nil A, xs)
|
||
|
||
def split-at : 0.(A : ★) → ℕ → List A → List A × List A =
|
||
λ A n xs ⇒
|
||
case split-at' A n xs return List A × List A of {
|
||
(xs', ys) ⇒ (reverse A xs', ys)
|
||
}
|
||
|
||
def filter : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → List A =
|
||
λ A p ⇒
|
||
foldrω A (List A)
|
||
(Nil A)
|
||
(λ x xs ⇒ bool.if (List A) (p x) (Cons A x xs) xs)
|
||
|
||
def length : 0.(A : ★) → ω.(List A) → ℕ =
|
||
λ A xs ⇒ fst xs
|
||
|
||
|
||
namespace zip-with {
|
||
def0 VFailure = vec.zip-with.Failure
|
||
def0 VSuccess = vec.zip-with.Success
|
||
|
||
def0 Failure : (A B : ★) → List A → List B → ★ =
|
||
λ A B xs ys ⇒ VFailure A B (fst xs) (fst ys) (snd xs) (snd ys)
|
||
|
||
def0 Result : (A B C : ★) → List A → List B → ★ =
|
||
λ A B C xs ys ⇒ Either (Failure A B xs ys) (List C)
|
||
|
||
def zip-with : 0.(A B C : ★) → ω.(A → B → C) →
|
||
(xs : List A) → (ys : List B) →
|
||
Result A B C xs ys =
|
||
λ A B C f xs ys ⇒
|
||
let0 Ret = Result A B C in
|
||
as-vec A (λ xs' ⇒ Ret xs' ys) xs (λ m xs ⇒
|
||
as-vec B (λ ys' ⇒ Ret (m, xs) ys') ys (λ n ys ⇒
|
||
let0 Err = Failure A B (m, xs) (n, ys) in
|
||
either.fold Err (VSuccess C m n) (Ret (m, xs) (n, ys))
|
||
(λ no ⇒ Left Err (List C) no)
|
||
(λ yes ⇒ case yes return Ret (m, xs) (n, ys) of { (vec, prf) ⇒
|
||
Right Err (List C) (drop0 (m ≡ n : ℕ) (List C) prf (n, vec))
|
||
})
|
||
(vec.zip-with-hetω A B C f m n xs ys)))
|
||
}
|
||
def0 ZipWith = zip-with.Result
|
||
def zip-with = zip-with.zip-with
|
||
|
||
def zip-withω : 0.(A B C : ★) → ω.(ω.A → ω.B → C) →
|
||
ω.(xs : List A) → ω.(ys : List B) →
|
||
Either [0. Not (fst xs ≡ fst ys : ℕ)] (List C) =
|
||
λ A B C f xs ys ⇒
|
||
letω m = fst xs; xs = snd xs;
|
||
n = fst ys; ys = snd ys in
|
||
let0 Err : ★ = [0. Not (m ≡ n : ℕ)] in
|
||
dec.elim (m ≡ n : ℕ) (λ _ ⇒ Either Err (List C))
|
||
(λ mn ⇒
|
||
letω xs = coe (𝑖 ⇒ Vec (mn @𝑖) A) xs in
|
||
Right Err (List C) (n, vec.zip-withω A B C f n xs ys))
|
||
(λ nmn ⇒ Left Err (List C) [nmn])
|
||
(nat.eq? m n)
|
||
def zip-with# = zip-withω
|
||
|
||
|
||
def zip-with-uneven :
|
||
0.(A B C : ★) → ω.(ω.A → ω.B → C) → ω.(List A) → ω.(List B) → List C =
|
||
λ A B C f xs ys ⇒
|
||
caseω nat.min (fst xs) (fst ys)
|
||
return ω.(List A) → ω.(List B) → List C of {
|
||
0 ⇒ λ _ _ ⇒ Nil C;
|
||
succ _, ω.fih ⇒ λ xs ys ⇒
|
||
maybe.foldω (A × List A) (List C) (Nil C)
|
||
(λ xxs ⇒ maybe.foldω (B × List B) (List C) (Nil C)
|
||
(λ yys ⇒ Cons C (f (fst xxs) (fst yys)) (fih (snd xxs) (snd yys)))
|
||
(list.uncons B ys))
|
||
(list.uncons A xs)
|
||
} xs ys
|
||
|
||
|
||
def sum : List ℕ → ℕ = foldl ℕ ℕ 0 nat.plus
|
||
def product : List ℕ → ℕ = foldl ℕ ℕ 1 nat.times
|
||
|
||
|
||
namespace mergesort {
|
||
def deal : 0.(A : ★) → List A → List A × List A =
|
||
λ A ⇒
|
||
let0 One = List A; Pair : ★ = One × One in
|
||
foldl A Pair (Nil A, Nil A)
|
||
(pair.uncurry' One One (A → Pair) (λ ys zs x ⇒ (Cons A x zs, ys)))
|
||
|
||
}
|
||
|
||
|
||
postulate0 SchemeList : ★ → ★
|
||
|
||
#[compile-scheme
|
||
"(lambda (list) (cons (length list) (fold-right cons 'nil list)))"]
|
||
postulate from-scheme : 0.(A : ★) → SchemeList A → List A
|
||
|
||
#[compile-scheme
|
||
"(lambda (lst)
|
||
(do [(lst (cdr lst) (cdr lst))
|
||
(acc '() (cons (car lst) acc))]
|
||
[(equal? lst 'nil) (reverse acc)]))"]
|
||
postulate to-scheme : 0.(A : ★) → List A → SchemeList A
|
||
|
||
}
|
||
|
||
def0 List = list.List
|