aoc2023/day1-standalone.quox

368 lines
9.7 KiB
Text
Raw Normal View History

2023-12-01 12:52:23 -05:00
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)
2023-12-02 08:20:50 -05:00
(λ _ p ⇒ succ p)
2023-12-01 12:52:23 -05:00
(λ _ _ 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 =
2023-12-02 08:20:50 -05:00
λ lo hi c ⇒ bool.and (le lo c) (le c hi)
2023-12-01 12:52:23 -05:00
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))