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 ⇒ p) (λ _ p ⇒ succ 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 ⇒ 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 } 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))