371 lines
9.9 KiB
Text
371 lines
9.9 KiB
Text
|
||
namespace bool {
|
||
|
||
def0 Bool : ★ = {true, false}
|
||
|
||
def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A =
|
||
λ A b t f ⇒ case b return A of { 'true ⇒ t; 'false ⇒ f }
|
||
|
||
def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false;
|
||
def or : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b;
|
||
|
||
}
|
||
|
||
def0 Bool = bool.Bool
|
||
|
||
namespace unit {
|
||
|
||
def0 Unit : ★ = {unit}
|
||
|
||
def drop : 0.(A : ★) → A → Unit → A =
|
||
λ A x u ⇒ case u return A of { 'unit ⇒ x }
|
||
|
||
}
|
||
|
||
def0 Unit = unit.Unit
|
||
|
||
|
||
namespace maybe {
|
||
|
||
def0 Tag : ★ = {nothing, just}
|
||
|
||
def0 Payload : Tag → ★ → ★ =
|
||
λ tag A ⇒ case tag return ★ of { 'nothing ⇒ Unit; 'just ⇒ A }
|
||
|
||
def0 Maybe : ★ → ★ =
|
||
λ A ⇒ (t : Tag) × Payload t A
|
||
|
||
def Nothing : 0.(A : ★) → Maybe A =
|
||
λ _ ⇒ ('nothing, 'unit)
|
||
|
||
def Just : 0.(A : ★) → A → Maybe A =
|
||
λ _ x ⇒ ('just, x)
|
||
|
||
|
||
def fold' : 0.(A B : ★) → ω.B → ω.(ω.A → B) →
|
||
ω.(t : Tag) → ω.(Payload t A) → B =
|
||
λ A B nothing just tag ⇒
|
||
case tag return t ⇒ ω.(Payload t A) → B of {
|
||
'nothing ⇒ λ _ ⇒ nothing;
|
||
'just ⇒ just
|
||
}
|
||
|
||
def fold : 0.(A B : ★) → ω.B → ω.(ω.A → B) → ω.(Maybe A) → B =
|
||
λ A B nothing just x ⇒
|
||
caseω x return B of { (tag, payload) ⇒ fold' A B nothing just tag payload }
|
||
|
||
def pair : 0.(A B : ★) → ω.(Maybe A) → ω.(Maybe B) → Maybe (A × B) =
|
||
λ A B x y ⇒
|
||
fold A (Maybe (A × B)) (Nothing (A × B))
|
||
(λ x' ⇒ fold B (Maybe (A × B)) (Nothing (A × B))
|
||
(λ y' ⇒ Just (A × B) (x', y')) y) x
|
||
|
||
|
||
def check : 0.(A : ★) → (ω.A → Bool) → ω.A → Maybe A =
|
||
λ A p x ⇒ bool.if (Maybe A) (p x) (Just A x) (Nothing A)
|
||
|
||
def or : 0.(A : ★) → ω.(Maybe A) → ω.(Maybe A) → Maybe A =
|
||
λ A l r ⇒ fold A (Maybe A) r (λ x ⇒ Just A x) l
|
||
|
||
}
|
||
|
||
def0 Maybe = maybe.Maybe
|
||
def Just = maybe.Just
|
||
def Nothing = maybe.Nothing
|
||
|
||
|
||
|
||
namespace vec {
|
||
|
||
def0 Vec : ℕ → ★ → ★ =
|
||
λ n A ⇒
|
||
case n return ★ of {
|
||
0 ⇒ Unit;
|
||
succ _, 0.Tail ⇒ A × Tail
|
||
}
|
||
|
||
def foldr : 0.(A B : ★) → B → ω.(A → B → B) → (n : ℕ) → Vec n A → B =
|
||
λ A B nil cons len ⇒
|
||
case len return l ⇒ Vec l A → B of {
|
||
0 ⇒ λ u ⇒ unit.drop B nil u;
|
||
succ n, f ⇒ λ lst ⇒
|
||
case lst return B of { (first, rest) ⇒ cons first (f rest) }
|
||
}
|
||
|
||
-- uggh
|
||
def foldrω : 0.(A B : ★) → ω.B → ω.(ω.A → ω.B → B) →
|
||
ω.(n : ℕ) → ω.(Vec n A) → B =
|
||
λ A B nil cons len ⇒
|
||
caseω len return l ⇒ ω.(Vec l A) → B of {
|
||
0 ⇒ λ _ ⇒ nil;
|
||
succ n, ω.f ⇒ λ lst ⇒ cons (fst lst) (f (snd lst))
|
||
}
|
||
|
||
}
|
||
|
||
|
||
|
||
namespace list {
|
||
|
||
def0 List : ★ → ★ =
|
||
λ A ⇒ (len : ℕ) × vec.Vec len A
|
||
|
||
def Nil : 0.(A : ★) → List A =
|
||
λ A ⇒ (0, 'unit)
|
||
|
||
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 foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B =
|
||
λ A B nil cons lst ⇒
|
||
case lst return B of { (len, elems) ⇒ vec.foldr A B nil cons len elems }
|
||
|
||
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 foldrω : 0.(A B : ★) → ω.B → ω.(ω.A → ω.B → B) → ω.(List A) → B =
|
||
λ A B nil cons lst ⇒
|
||
caseω lst return B of { (len, elems) ⇒ vec.foldrω A B nil cons len elems }
|
||
|
||
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)
|
||
|
||
|
||
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))
|
||
|
||
|
||
postulate0 SchemeList : ★ → ★
|
||
|
||
#[compile-scheme
|
||
"(lambda (list) (cons (length list) (fold-right cons 'unit list)))"]
|
||
postulate from-scheme : 0.(A : ★) → SchemeList A → List A
|
||
|
||
}
|
||
|
||
def0 List = list.List
|
||
def Nil = list.Nil
|
||
def Cons = list.Cons
|
||
|
||
|
||
namespace nat {
|
||
|
||
-- recurse over two numbers in lockstep until one reaches zero
|
||
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')
|
||
}
|
||
}
|
||
|
||
#[compile-scheme "(lambda (n) n)"]
|
||
def dup : ℕ → [ω. ℕ] =
|
||
λ n ⇒
|
||
case n return n' ⇒ [ω. ℕ] of {
|
||
0 ⇒ [0];
|
||
succ n, d ⇒ case d return [ω.ℕ] of { [n'] ⇒ [succ n'] }
|
||
};
|
||
|
||
#[compile-scheme "(lambda% (m n) (+ m n))"]
|
||
def plus : ℕ → ℕ → ℕ =
|
||
λ m n ⇒
|
||
case m return ℕ of {
|
||
0 ⇒ n;
|
||
succ _, p ⇒ succ p
|
||
};
|
||
|
||
#[compile-scheme "(lambda% (m n) (* m n))"]
|
||
def timesω : ℕ → ω.ℕ → ℕ =
|
||
λ m n ⇒
|
||
case m return ℕ of {
|
||
0 ⇒ 0;
|
||
succ _, t ⇒ plus n t
|
||
};
|
||
|
||
def times : ℕ → ℕ → ℕ =
|
||
λ m n ⇒ case dup n return ℕ of { [n] ⇒ timesω m n };
|
||
|
||
def pred : ℕ → ℕ =
|
||
λ n ⇒ case n return ℕ of { 0 ⇒ 0; succ n ⇒ n };
|
||
|
||
#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"]
|
||
def minus : ℕ → ℕ → ℕ =
|
||
λ m n ⇒
|
||
case dup m return ℕ of { [m] ⇒
|
||
elim-pair (λ _ _ ⇒ ℕ)
|
||
0
|
||
(λ _ p ⇒ succ p)
|
||
(λ _ p ⇒ p)
|
||
(λ _ _ p ⇒ p)
|
||
m n
|
||
}
|
||
|
||
|
||
def0 Ordering : ★ = {lt, eq, gt}
|
||
|
||
def from-ordering : 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-ordering : 0.(A : ★) → Ordering → A → A =
|
||
λ A o x ⇒ case o return A of { 'lt ⇒ x; 'eq ⇒ x; 'gt ⇒ x }
|
||
|
||
def compareω : ω.ℕ → ℕ → Ordering =
|
||
elim-pair (λ _ _ ⇒ Ordering)
|
||
'eq
|
||
(λ _ o ⇒ drop-ordering Ordering o 'lt)
|
||
(λ _ o ⇒ drop-ordering Ordering o 'gt)
|
||
(λ _ _ x ⇒ x)
|
||
|
||
def compare : ℕ → ℕ → Ordering =
|
||
λ m n ⇒ case dup m return Ordering of { [m] ⇒ compareω m n }
|
||
|
||
def le : ω.ℕ → ω.ℕ → Bool =
|
||
λ m n ⇒
|
||
case compare m n return Bool
|
||
of { 'lt ⇒ 'true; 'eq ⇒ 'true; 'gt ⇒ 'false }
|
||
|
||
}
|
||
|
||
|
||
namespace io {
|
||
|
||
def0 IORes : ★ → ★ = λ A ⇒ A × IOState
|
||
|
||
def0 IO : ★ → ★ = λ A ⇒ IOState → IORes A
|
||
|
||
def pure : 0.(A : ★) → A → IO A = λ A x s ⇒ (x, s)
|
||
|
||
def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B =
|
||
λ A B m k s0 ⇒
|
||
case m s0 return IORes B of { (x, s1) ⇒ k x s1 }
|
||
|
||
def map : 0.(A B : ★) → (A → B) → IO A → IO B =
|
||
λ A B f act ⇒ bind A B act (λ x ⇒ pure B (f x))
|
||
|
||
def seq : 0.(B : ★) → IO Unit → IO B → IO B =
|
||
λ B x y ⇒ bind Unit B x (λ u ⇒ case u return IO B of { 'unit ⇒ y })
|
||
|
||
def seq' : IO Unit → IO Unit → IO Unit = seq Unit
|
||
|
||
#[compile-scheme "(lambda (x) (builtin-io (display x) (newline)))"]
|
||
postulate dump : 0.(A : ★) → A → IO Unit
|
||
|
||
#[compile-scheme
|
||
"(lambda (path) (builtin-io
|
||
(call-with-input-file path
|
||
(lambda (file)
|
||
(do [(line (get-line file) (get-line file))
|
||
(acc '() (cons line acc))]
|
||
[(eof-object? line) (reverse acc)])))))"]
|
||
postulate prim-read-file-lines :
|
||
ω.(path : String) → IO (list.SchemeList String)
|
||
|
||
def read-file-lines : ω.(path : String) → IO (List String) =
|
||
λ path ⇒
|
||
map (list.SchemeList String) (List String)
|
||
(list.from-scheme String)
|
||
(prim-read-file-lines path)
|
||
|
||
}
|
||
|
||
def0 IO = io.IO
|
||
|
||
|
||
namespace char {
|
||
postulate0 Char : ★
|
||
|
||
#[compile-scheme "char->integer"]
|
||
postulate ord : Char → ℕ
|
||
|
||
#[compile-scheme "integer->char"]
|
||
postulate chr : ℕ → Char
|
||
|
||
#[compile-scheme "(lambda (c) c)"]
|
||
postulate dup : Char → [ω.Char]
|
||
|
||
def le : ω.Char → ω.Char → Bool =
|
||
λ x y ⇒ nat.le (ord x) (ord y)
|
||
|
||
def between : ω.Char → ω.Char → ω.Char → Bool =
|
||
λ lo hi c ⇒
|
||
case dup c return Bool of { [c] ⇒ bool.and (le lo c) (le c hi) }
|
||
|
||
def is-digit : ω.Char → Bool =
|
||
between (chr 0x30) (chr 0x39)
|
||
|
||
def digit : Char → ℕ =
|
||
λ c ⇒ nat.minus (ord c) 0x30
|
||
|
||
#[compile-scheme "(lambda (c) (builtin-io (display c) (newline)))"]
|
||
postulate println : Char → IO Unit
|
||
}
|
||
|
||
def0 Char = char.Char
|
||
|
||
|
||
namespace string {
|
||
#[compile-scheme "string->list"]
|
||
postulate prim-to-list : String → list.SchemeList Char
|
||
|
||
def to-list : String → List Char =
|
||
λ str ⇒ list.from-scheme Char (prim-to-list str)
|
||
|
||
#[compile-scheme "(lambda (str) str)"]
|
||
postulate dup : String → [ω.String]
|
||
}
|
||
|
||
|
||
def find-first-last :
|
||
0.(A : ★) →
|
||
ω.(ω.A → Bool) →
|
||
ω.(List A) → Maybe (A × A) =
|
||
λ A p xs ⇒
|
||
maybe.pair A A
|
||
(list.find A p xs)
|
||
(list.find A p (list.reverse A xs))
|
||
|
||
def number' : Char → Char → ℕ =
|
||
λ tens units ⇒ nat.plus (nat.times 10 (char.digit tens)) (char.digit units)
|
||
|
||
def number : String → ℕ =
|
||
λ line ⇒
|
||
case string.dup line return ℕ of {
|
||
[line] ⇒
|
||
maybe.fold (Char × Char) ℕ 0
|
||
(λ cd ⇒ case cd return ℕ of { (c, d) ⇒ number' c d })
|
||
(find-first-last Char char.is-digit (string.to-list line))
|
||
}
|
||
|
||
def part1 : List String → ℕ =
|
||
list.foldr String ℕ 0 (λ str n ⇒ nat.plus (number str) n)
|
||
|
||
|
||
#[main]
|
||
def main : IO Unit =
|
||
io.bind (List String) Unit
|
||
(io.read-file-lines "in/day1")
|
||
(λ lines ⇒ io.dump ℕ (part1 lines))
|