aoc2023/day1-standalone.quox

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))