more

day10.pl

@@ -0,0 +1,55 @@
+:- use_module(library(dcg/basics)).
+:- use_module(library(ugraphs)).
+:- use_module(library(assoc)).
+
+char(X, L, C0, L, C) -->
+  [X0], {X0 \= 0'\n, char_code(X, X0), C is C0 + 1}, !.
+
+newline(L0, _, L, 0) --> "\n", {L is L0 + 1}.
+
+empty(L, C0, L, C)    --> char('.', L, C0, L, C).
+pipe(Ds, L, C0, L, C) --> char(X, L, C0, L, C), {is_pipe(X, Ds)}.
+start(L, C0, L, C)    --> char('S', L, C0, L, C).
+
+is_pipe('F', [down, right]).
+is_pipe('L', [up,   right]).
+is_pipe('7', [down, left]).
+is_pipe('J', [up,   left]).
+is_pipe('-', [left, right]).
+is_pipe('|', [up,   down]).
+
+
+nonthing(L0, C0, L, C) --> empty(L0, C0, L, C).
+nonthing(L0, C0, L, C) --> newline(L0, C0, L, C).
+
+thing(s(L0, C0),    L0, C0, L, C) --> start(L0, C0, L, C).
+thing(p(P, L0, C0), L0, C0, L, C) --> pipe(P, L0, C0, L, C).
+
+map([], L, C, L, C)       --> [].
+map(Xs, L0, C0, L, C)     --> nonthing(L0, C0, L1, C1), map(Xs, L1, C1, L, C).
+map([X|Xs], L0, C0, L, C) --> thing(X, L0, C0, L1, C1), map(Xs, L1, C1, L, C).
+
+map(Xs) --> map(Xs, 0, 0, _, _).
+
+insert(s(L, C),    A0, A) :- put_assoc(L-C, A0, s,    A).
+insert(p(P, L, C), A0, A) :- put_assoc(L-C, A0, p(P), A).
+
+make_assoc(Map, A) :-
+  empty_assoc(Start),
+  foldl(insert, Map, Start, A).
+
+parse(File, A) :-
+  phrase_from_file(map(Map), File), !,
+  make_assoc(Map, A).
+
+converse(up,    down).
+converse(down,  up).
+converse(left,  right).
+converse(right, left).
+
+compat(p(Ds1), p(Ds2)) :- member(D1, Ds1), member(D2, Ds2), converse(D1, D2), !.
+compat(s,      p(_)).
+compat(p(_),   s).
+
+
+% vim: set ft=prolog :

day12.pl

@@ -0,0 +1,84 @@
+:- use_module(library(dcg/basics)).
+:- use_module(library(dcg/high_order)).
+
+ok([],     [],     []).
+ok([T|Ts], Cs,     [0'.|Rs]) :- can_empty(T), ok(Ts, Cs, Rs).
+ok(Ts,     [C|Cs], Rs)       :- fill(Ts, C, Rs, Ts1, Rs1), ok(Ts1, Cs, Rs1).
+
+fill([],     0, [],       [],  []).
+fill([T|Ts], 0, [0'.|Rs], Ts,  Rs)  :- can_empty(T).
+fill([T|Ts], C, [0'#|Rs], Ts1, Rs1) :-
+  C > 0, C1 is C - 1,
+  can_fill(T), fill(Ts, C1, Rs, Ts1, Rs1).
+
+can_fill(0'#).
+can_fill(0'?).
+
+can_empty(0'.).
+can_empty(0'?).
+
+count(T, C, N) :- bagof(S, ok(T, C, S), Ss), length(Ss, N).
+count(T-C,  N) :- count(T, C, N).
+
+examples1 :-
+  count(`???.###`,             [1, 1, 3],    1),
+  count(`.??..??...?##.`,      [1, 1, 3],    4),
+  count(`?#?#?#?#?#?#?#?`,     [1, 3, 1, 6], 1),
+  count(`????.#...#...`,       [4, 1, 1],    1),
+  count(`????.######..#####.`, [1, 6, 5],    4),
+  count(`?###????????`,        [3, 2, 1],    10).
+
+
+file(Lines) --> sequence(line, Lines).
+line(T-C)   --> template(T), " ", clues(C), blanks.
+template(T) --> sequence(tchar, T).
+tchar(T)    --> [T], {member(T, `?#.`)}.
+clues(C)    --> sequence(number, ",", C).
+
+
+part1(File) :-
+  phrase_from_file(file(TCs), File), !,
+  maplist(count, TCs, Ns),
+  foldl(plus, Ns, 0, N),
+  writeln(N).
+
+
+/*
+
+% oof ouch my stack ☹
+
+count_unfold(T-C, N) :-
+  unfold_template(T, T1),
+  unfold_clues(C, C1),
+  count(T1-C1, N).
+
+unfold_template(T, R) :- unfold_template(5, T, R).
+unfold_template(1, T, T) :- !.
+unfold_template(N, T, R) :-
+  N > 1, N1 is N - 1,
+  unfold_template(N1, T, R1),
+  append(T, [0'?|R1], R).
+
+unfold_clues(C, R) :- unfold_clues(5, C, R).
+unfold_clues(1, C, C) :- !.
+unfold_clues(N, C, R) :-
+  N > 1, N1 is N - 1,
+  unfold_clues(N1, C, R1),
+  append(C, R1, R).
+
+examples2 :-
+  count_unfold(`???.###`-[1,1,3], 1),
+  count_unfold(`.??..??...?##.`-[1,1,3], 16384),
+  count_unfold(`?#?#?#?#?#?#?#?`-[1,3,1,6], 1),
+  count_unfold(`????.#...#...`-[4,1,1], 16),
+  count_unfold(`????.######..#####.`-[1,6,5], 2500),
+  count_unfold(`?###????????`-[3,2,1], 506250).
+
+
+part2(File) :-
+  phrase_from_file(file(TCs), File), !,
+  maplist(count_unfold, TCs, Ns),
+  foldl(plus, Ns, 0, N),
+  writeln(N).
+
+*/

day3.pl

@@ -77,3 +77,5 @@ part2(File) :-
   bagof(R, gear(R), Rs),
   sum(Rs, Total),
   writeln(Total).
+
+% vim: set ft=prolog :

day5.pl

@@ -20,8 +20,7 @@ part(p(From, To, Elems)) -->
   header(From, To), blanks, blank_sep(map_line, Elems), blanks.
 
 
-file1(Seeds, Parts) -->
+file1(Seeds, Parts) --> seed_list(Seeds), blanks, many(part, Parts).
-  seed_list(Seeds), blanks, many(part, Parts).
 
 parse1(Seeds, Parts, File) :- once(phrase_from_file(file1(Seeds, Parts), File)).
 
@@ -65,4 +64,25 @@ part1(File) :-
   writeln(L).
 
 
+seed_ranges(Seeds) --> "seeds:", blanks, blank_sep(seed_range, Seeds).
+seed_range(s(Lo, Len)) --> numbers([Lo, Len]).
+
+file2(Seeds, Parts) --> seed_ranges(Seeds), blanks, many(part, Parts).
+
+parse2(Seeds, Parts, File) :- once(phrase_from_file(file2(Seeds, Parts), File)).
+
+
+min_range(To, Lo, Hi) :-
+  setof(r(Dest, Len),
+        From^Src^entry(From, To, Src, Dest, Len),
+        [r(Lo0, Len)|_]),
+  Hi0 is Lo0 + Len,
+  Hi1 is Lo0 - 1,
+  (Lo = Lo0, Hi = Hi0 ; Lo = 0, Hi = Hi1).
+
+range_size(s(_, Len), Len).
+seed_count(Seeds, N) :-
+  maplist(range_size, Seeds, Sizes),
+  foldl(plus, Sizes, 0, N).
+
 % vim: set ft=prolog :

day9.quox

@@ -0,0 +1,78 @@
+load "bool.quox"
+load "list.quox"
+load "maybe.quox"
+load "int.quox"
+
+
+def0 Int = scheme-int.Int
+
+def zz = scheme-int.from-ℕ 0
+
+def step : ω.(List Int) → List Int =
+  λ xs ⇒
+    list.zip-with-uneven Int Int Int (λ m n ⇒ scheme-int.minus n m)
+      xs (list.tail-or-nil Int xs)
+
+def all-zero : ω.(List Int) → Bool =
+  list.foldlω Int Bool 'true (λ b n ⇒ bool.and b (scheme-int.eq n zz))
+
+def last : 0.(A : ★) → ω.(List A) → Maybe A =
+  λ A ⇒ list.foldrω A (Maybe A) (Nothing A) (λ x y ⇒ maybe.or A y (Just A x))
+
+def0 last-ok : last ℕ (4, 1, 4, 8, 5, 'nil) ≡ Just ℕ 5 : Maybe ℕ =
+  δ 𝑖 ⇒ Just ℕ 5
+
+def last-or-0 : ω.(List Int) → Int =
+  λ xs ⇒ maybe.fold Int Int zz (λ x ⇒ x) (last Int xs)
+
+def next-entry : ω.(List ℕ) → Int =
+  λ xs ⇒
+    letω fuel = fst xs in
+    letω xs = list.map ℕ Int scheme-int.from-ℕ xs in
+    let result : Int =
+      caseω fuel return ω.(List Int) → Int of {
+        0             ⇒ λ _ ⇒ zz;
+        succ _, ω.rec ⇒ λ this ⇒
+          bool.if Int (all-zero this) zz
+            (letω next : List Int = step this in
+             letω diff : Int = rec next in
+             scheme-int.plus diff (last-or-0 this))
+      } xs in
+    result
+
+def sumZ = list.foldr Int Int zz scheme-int.plus
+
+{-
+def0 ok-1 : next-entry (6, 0,  3,  6,  9,  12, 15, 'nil) ≡ 18 : ℕ = δ _ ⇒ 18
+def0 ok-2 : next-entry (6, 1,  3,  6,  10, 15, 21, 'nil) ≡ 28 : ℕ = δ _ ⇒ 28
+def0 ok-3 : next-entry (6, 10, 13, 16, 21, 30, 45, 'nil) ≡ 68 : ℕ = δ _ ⇒ 68
+-}
+
+load "io.quox"
+load "string.quox"
+
+
+def read-file : ω.String → IO [ω.List (List ℕ)] =
+  λ path ⇒
+    letω split-lines : ω.String → List String =
+           string.split (λ c ⇒ char.eq c char.newline);
+         split-numbers : ω.String → List ℕ = λ str ⇒
+           let words = string.split char.ws? str in
+           list.map String ℕ string.to-ℕ-or-0 words;
+         split-file : ω.String → [ω. List (List ℕ)] = λ str ⇒
+           [list.mapω String (List ℕ) split-numbers (split-lines str)] in
+    io.mapω String [ω.List (List ℕ)] split-file (io.read-fileω path)
+
+def FILE : String = "in/day9"
+
+#[main]
+def part1 =
+  io.bindω (List (List ℕ)) True
+    (read-file FILE)
+    (λ lists ⇒ io.dump Int (sumZ (list.mapω (List ℕ) Int next-entry lists)))
+
+def part2 : IO True =
+  letω next-entry-r : ω.(List ℕ) → Int = λ xs ⇒ next-entry (list.reverse ℕ xs) in
+  io.bindω (List (List ℕ)) True
+    (read-file FILE)
+    (λ lists ⇒ io.dump Int (sumZ (list.mapω (List ℕ) Int next-entry-r lists)))

day9.tooslow.quox

@@ -0,0 +1,88 @@
+load "bool.quox"
+load "list.quox"
+load "maybe.quox"
+load "int.quox"
+
+
+def zz = int.zeroℤ
+
+def step : ω.(List ℤ) → List ℤ =
+  λ xs ⇒
+    list.zip-with-uneven ℤ ℤ ℤ (λ m n ⇒ int.minus n m)
+      xs (list.tail-or-nil ℤ xs)
+
+def all-zero : ω.(List ℤ) → Bool =
+  list.foldlω ℤ Bool 'true (λ b n ⇒ bool.and b (int.eq n zz))
+
+def last : 0.(A : ★) → ω.(List A) → Maybe A =
+  λ A ⇒ list.foldrω A (Maybe A) (Nothing A) (λ x y ⇒ maybe.or A y (Just A x))
+
+def0 last-ok : last ℕ (4, 1, 4, 8, 5, 'nil) ≡ Just ℕ 5 : Maybe ℕ =
+  δ 𝑖 ⇒ Just ℕ 5
+
+def last-or-0 : ω.(List ℤ) → ℤ =
+  λ xs ⇒ maybe.fold ℤ ℤ zz (λ x ⇒ x) (last ℤ xs)
+
+{-
+def next-entries : ω.(List ℕ) → List ℕ =
+  λ xs ⇒
+    letω fuel = fst xs in
+    caseω fuel return ω.(List ℕ) → List ℕ of {
+      0             ⇒ λ _ ⇒ list.Nil ℕ;
+      succ _, ω.rec ⇒ λ this ⇒
+        bool.if (List ℕ) (all-zero this) (list.Nil ℕ)
+          (letω next : List ℕ = step this in
+           letω rest : List ℕ = rec next in
+           letω new  : ℕ = nat.plus (last-or-0 this) (head-or-0 rest) in
+           list.Cons ℕ new rest)
+    } xs
+-}
+
+def next-entry : ω.(List ℕ) → ℕ =
+  λ xs ⇒
+    letω fuel = fst xs in
+    letω xs = list.map ℕ ℤ int.from-ℕ xs in
+    let result : ℤ =
+      caseω fuel return ω.(List ℤ) → ℤ of {
+        0             ⇒ λ _ ⇒ zz;
+        succ _, ω.rec ⇒ λ this ⇒
+          bool.if ℤ (all-zero this) zz
+            (letω next : List ℤ = step this in
+             letω diff : ℤ = rec next in
+             int.plus diff (last-or-0 this))
+      } xs in
+    int.abs result
+
+def0 ok-1 : next-entry (6, 0,  3,  6,  9,  12, 15, 'nil) ≡ 18 : ℕ = δ _ ⇒ 18
+def0 ok-2 : next-entry (6, 1,  3,  6,  10, 15, 21, 'nil) ≡ 28 : ℕ = δ _ ⇒ 28
+def0 ok-3 : next-entry (6, 10, 13, 16, 21, 30, 45, 'nil) ≡ 68 : ℕ = δ _ ⇒ 68
+
+
+load "io.quox"
+load "string.quox"
+
+
+def read-file : ω.String → IO [ω.List (List ℕ)] =
+  λ path ⇒
+    letω split-lines : ω.String → List String =
+           string.split (λ c ⇒ char.eq c char.newline);
+         split-numbers : ω.String → List ℕ = λ str ⇒
+           let words = string.split char.ws? str in
+           list.map String ℕ string.to-ℕ-or-0 words;
+         split-file : ω.String → [ω. List (List ℕ)] = λ str ⇒
+           [list.mapω String (List ℕ) split-numbers (split-lines str)] in
+    io.mapω String [ω.List (List ℕ)] split-file (io.read-fileω path)
+
+def FILE : String = "in/day9"
+
+-- #[main]
+def doot =
+  io.bindω (List (List ℕ)) True
+    (read-file FILE)
+    (λ lists ⇒ io.dump (List (List ℕ)) lists)
+
+#[main]
+def part1 =
+  io.bindω (List (List ℕ)) True
+    (read-file FILE)
+    (λ lists ⇒ io.dump ℕ (list.sum (list.mapω (List ℕ) ℕ next-entry lists)))

lib/either.quox

@@ -75,6 +75,9 @@ def0 Dec : ★ → ★ = λ A ⇒ Either [0.A] [0.Not A]
 def Yes : 0.(A : ★) → 0.A       → Dec A = λ A y ⇒ Left  [0.A] [0.Not A] [y]
 def No  : 0.(A : ★) → 0.(Not A) → Dec A = λ A n ⇒ Right [0.A] [0.Not A] [n]
 
+def yes-refl : 0.(A : ★) → 0.(x : A) → Dec (x ≡ x : A) =
+  λ A x ⇒ Yes (x ≡ x : A) (δ 𝑖 ⇒ x)
+
 def0 DecEq : ★ → ★ =
   λ A ⇒ ω.(x : A) → ω.(y : A) → Dec (x ≡ y : A)
 

lib/int.quox

@@ -0,0 +1,149 @@
+load "nat.quox"
+
+namespace int {
+
+def0 Sign : ★ = {pos, neg-succ}
+def0 ℤ : ★ = Sign × ℕ
+
+def from-ℕ : ℕ → ℤ = λ n ⇒ ('pos, n)
+
+def neg-ℕ : ℕ → ℤ =
+  λ n ⇒ case n return ℤ of { 0 ⇒ ('pos, 0); succ n ⇒ ('neg-succ, n) }
+
+def zeroℤ : ℤ = ('pos, 0)
+
+
+def match : 0.(A : ★) → ω.(pos neg : ℕ → A) → ℤ → A =
+  λ A pos neg x ⇒
+    case x return A of { (s, x) ⇒
+      case s return A of { 'pos ⇒ pos x; 'neg-succ ⇒ neg x }
+    }
+
+def negate : ℤ → ℤ =
+  match ℤ neg-ℕ (λ x ⇒ from-ℕ (succ x))
+
+def minus-ℕ-ℕ : ℕ → ℕ → ℤ =
+  λ m n ⇒
+    letω f : ω.ℕ → ω.ℕ → ℤ = λ m n ⇒
+      bool.if ℤ (nat.ge m n) (from-ℕ (nat.minus m n))
+                             (neg-ℕ (nat.minus n m)) in
+    getω ℤ (app2ω ℕ ℕ ℤ f (nat.dup m) (nat.dup n))
+
+def plus-ℕ : ℤ → ℕ → ℤ =
+  match (ℕ → ℤ) (λ x n ⇒ from-ℕ (nat.plus x n))
+                (λ x n ⇒ minus-ℕ-ℕ n (succ x))
+
+def minus-ℕ : ℤ → ℕ → ℤ =
+  match (ℕ → ℤ) minus-ℕ-ℕ (λ x n ⇒ ('neg-succ, nat.plus x n))
+
+
+def plus : ℤ → ℤ → ℤ =
+  match (ℤ → ℤ) (λ x y ⇒ plus-ℕ y x) (λ x y ⇒ minus-ℕ y (succ x))
+
+def minus : ℤ → ℤ → ℤ = λ x y ⇒ plus x (negate y)
+
+
+def dup-sign : Sign → [ω. Sign] =
+  λ s ⇒ case s return [ω. Sign] of {
+    'pos      ⇒ ['pos];
+    'neg-succ ⇒ ['neg-succ]
+  }
+
+def0 dup-sign-ok : (s : Sign) → dup-sign s ≡ [s] : [ω. Sign] =
+  λ s ⇒ case s return s' ⇒ dup-sign s' ≡ [s'] : [ω. Sign] of {
+    'pos      ⇒ δ 𝑖 ⇒ ['pos];
+    'neg-succ ⇒ δ 𝑖 ⇒ ['neg-succ]
+  }
+
+def dup : ℤ → [ω.ℤ] =
+  λ x ⇒ case x return [ω.ℤ] of { (s, n) ⇒
+    app2ω Sign ℕ ℤ (λ s n ⇒ (s, n)) (dup-sign s) (nat.dup n)
+  }
+
+def0 dup-ok : (x : ℤ) → dup x ≡ [x] : [ω.ℤ] =
+  λ x ⇒
+  case x return x' ⇒ dup x' ≡ [x'] : [ω.ℤ] of { (s, n) ⇒ δ 𝑖 ⇒
+    app2ω Sign ℕ ℤ (λ s n ⇒ (s, n)) (dup-sign-ok s @𝑖) (nat.dup-ok n @𝑖)
+  }
+
+
+def times-ℕ : ℤ → ℕ → ℤ =
+  match (ℕ → ℤ)
+    (λ m  n ⇒ from-ℕ (nat.times m n))
+    (λ m' n ⇒ neg-ℕ (nat.times (succ m') n))
+
+def times : ℤ → ℤ → ℤ =
+  match (ℤ → ℤ) (λ p x ⇒ times-ℕ x p) (λ n x ⇒ negate (times-ℕ x (succ n)))
+
+
+def abs : ℤ → ℕ = match ℕ (λ p ⇒ p) (λ n ⇒ succ n)
+
+
+def pair-eq? : 0.(A B : ★) → ω.(DecEq A) → ω.(DecEq B) → DecEq (A × B) =
+  λ A B eqA? eqB? x y ⇒
+    let0 Ret : ★ = x ≡ y : (A × B) in
+    letω a0 = fst x; a1 = fst y;
+         b0 = snd x; b1 = snd y in
+    dec.elim (a0 ≡ a1 : A) (λ _ ⇒ Dec Ret)
+      (λ ya ⇒
+        dec.elim (b0 ≡ b1 : B) (λ _ ⇒ Dec Ret)
+          (λ yb ⇒ Yes Ret (δ 𝑖 ⇒ (ya @𝑖, yb @𝑖)))
+          (λ nb ⇒ No  Ret (λ eq ⇒ nb (δ 𝑖 ⇒ snd (eq @𝑖))))
+          (eqB? b0 b1))
+      (λ na ⇒ No Ret (λ eq ⇒ na (δ 𝑖 ⇒ fst (eq @𝑖))))
+      (eqA? a0 a1)
+
+
+def sign-eq? : DecEq Sign =
+  λ x y ⇒
+    let0 disc : Sign → ★ =
+      λ s ⇒ case s return ★ of { 'pos ⇒ True; 'neg-succ ⇒ False } in
+  case x return x' ⇒ Dec (x' ≡ y : Sign) of {
+    'pos ⇒
+      case y return y' ⇒ Dec ('pos ≡ y' : Sign) of {
+        'pos ⇒ dec.yes-refl Sign 'pos;
+        'neg-succ ⇒
+          No ('pos ≡ 'neg-succ : Sign)
+             (λ eq ⇒ coe (𝑖 ⇒ disc (eq @𝑖)) 'true)
+      };
+    'neg-succ ⇒
+      case y return y' ⇒ Dec ('neg-succ ≡ y' : Sign) of {
+        'neg-succ ⇒ dec.yes-refl Sign 'neg-succ;
+        'pos ⇒
+          No ('neg-succ ≡ 'pos : Sign)
+             (λ eq ⇒ coe (𝑖 ⇒ disc (eq @𝑖)) @1 @0 'true)
+      }
+  }
+
+#[compile-scheme "(lambda% (x y) (if (equal? x y) Yes No))"]
+def eq? : DecEq ℤ = pair-eq? Sign ℕ sign-eq? nat.eq?
+
+def eq : ω.ℤ → ω.ℤ → Bool =
+  λ x y ⇒ dec.bool (x ≡ y : ℤ) (eq? x y)
+
+}
+
+def0 ℤ = int.ℤ
+
+
+namespace scheme-int {
+  postulate0 Int : ★
+
+  #[compile-scheme "(lambda (x) x)"]
+  postulate from-ℕ : ℕ → Int
+
+  #[compile-scheme "(lambda% (x y) (+ x y))"]
+  postulate plus : Int → Int → Int
+
+  #[compile-scheme "(lambda% (x y) (- x y))"]
+  postulate minus : Int → Int → Int
+
+  #[compile-scheme "(lambda% (x y) (* x y))"]
+  postulate times : Int → Int → Int
+
+  #[compile-scheme "(lambda% (x y) (if (= x y) 'true 'false))"]
+  postulate eq : Int → Int → Bool
+
+  #[compile-scheme "abs"]
+  postulate abs : Int → ℕ
+}

lib/io.quox

@@ -23,6 +23,9 @@ def bindω : 0.(A B : ★) → IO [ω.A] → (ω.A → IO B) → IO B =
 def map : 0.(A B : ★) → (A → B) → IO A → IO B =
   λ A B f m ⇒ bind A B m (λ x ⇒ pure B (f x))
 
+def mapω : 0.(A B : ★) → (ω.A → B) → IO [ω.A] → IO B =
+  λ A B f m ⇒ bindω A B m (λ x ⇒ pure B (f x))
+
 def seq : 0.(B : ★) → IO True → IO B → IO B =
   λ B x y ⇒ bind True B x (λ u ⇒ case u return IO B of { 'true ⇒ y })
 
@@ -33,7 +36,7 @@ def pass : IO True = pure True 'true
 #[compile-scheme "(lambda (str) (builtin-io (display str) 'true))"]
 postulate print : String → IO True
 
-#[compile-scheme "(lambda (str) (builtin-io (display str) (newline) 'true))"]
+#[compile-scheme "(lambda (str) (builtin-io (write str) (newline) 'true))"]
 postulate dump : 0.(A : ★) → A → IO True
 
 def newline = print "\n"

lib/list.quox

@@ -111,6 +111,29 @@ def zip-withω : 0.(A B C : ★) → ω.(ω.A → ω.B → C) →
   λ A B C f ⇒
     elimω2 A B (λ n _ _ ⇒ Vec n C) 'nil (λ a b _ _ _ abs ⇒ (f a b, abs))
 
+
+def0 ZipWithFailure : (m n : ℕ) → (A B : ★) → Vec m A → Vec n B → ★ =
+  λ m n A B xs ys ⇒ Sing (Vec m A) xs × Sing (Vec n B) ys × [0. Not (m ≡ n : ℕ)]
+
+def zip-with-het : 0.(A B C : ★) → ω.(A → B → C) →
+                   ω.(m : ℕ) → (xs : Vec m A) →
+                   ω.(n : ℕ) → (ys : Vec n B) →
+                   Either (ZipWithFailure m n A B xs ys)
+                          (Vec n C × [0. m ≡ n : ℕ]) =
+  λ A B C f m xs n ys ⇒
+    let0 TNo  : Vec m A → Vec n B → ★ = λ xs ys ⇒ ZipWithFailure m n A B xs ys;
+         TYes : ★ = Vec n C × [0. 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
+
 #[compile-scheme "(lambda% (n xs) xs)"]
 def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A =
   λ A n ⇒
@@ -311,11 +334,8 @@ def length : 0.(A : ★) → ω.(List A) → ℕ =
   λ A xs ⇒ fst xs
 
 
-def0 ZipWithFailureVec : (m n : ℕ) → (A B : ★) → Vec m A → Vec n B → ★ =
-  λ m n A B xs ys ⇒ Sing (Vec m A) xs × Sing (Vec n B) ys × [0. Not (m ≡ n : ℕ)]
-
 def0 ZipWithFailure : (A B : ★) → List A → List B → ★ =
-  λ A B xs ys ⇒ ZipWithFailureVec (fst xs) (fst ys) A B (snd xs) (snd ys)
+  λ A B xs ys ⇒ vec.ZipWithFailure (fst xs) (fst ys) A B (snd xs) (snd ys)
 
 {-
 -- unfinished
@@ -376,6 +396,10 @@ def zip-with-uneven :
     } xs ys
 
 
+def sum     : List ℕ → ℕ = foldl ℕ ℕ 0 nat.plus
+def product : List ℕ → ℕ = foldl ℕ ℕ 1 nat.times
+
+
 {-
 -- unfinished
 def zip-with : 0.(A B C : ★) → ω.(A → B → C) →
@@ -422,11 +446,10 @@ postulate0 SchemeList : ★ → ★
 postulate from-scheme : 0.(A : ★) → SchemeList A → List A
 
 #[compile-scheme
-  "(lambda (list)
+ "(lambda (lst)
-    (let loop [(acc '()) (list (cdr list))]
+    (do [(lst (cdr lst) (cdr lst))
-      (if (pair? list)
+         (acc '()       (cons (car lst) acc))]
-        (loop (cons (car list) acc) (cdr list))
+      [(equal? lst 'nil) (reverse acc)]))"]
-        (reverse acc))))"]
 postulate to-scheme : 0.(A : ★) → List A → SchemeList A
 
 }

lib/misc.quox

@@ -87,6 +87,29 @@ def0 Sing : (A : ★) → A → ★ =
 def sing : 0.(A : ★) → (x : A) → Sing A x =
   λ A x ⇒ (x, [δ _ ⇒ x])
 
+def0 Dup : (A : ★) → A → ★ =
+  λ A x ⇒ [ω. Sing A x]
+
+def dup-from-parts :
+    0.(A : ★) →
+    (dup : A → [ω.A]) →
+    0.(prf : (x : A) → dup x ≡ [x] : [ω.A]) →
+    (x : A) → Dup A x =
+  λ A dup prf x ⇒
+    case dup x return x! ⇒ 0.(x! ≡ dup x : [ω.A]) → [ω. Sing A x] of {
+      [x'] ⇒ λ eq ⇒
+        let0 prf'-ω : [x'] ≡ [x] : [ω.A] =
+               trans [ω.A] [x'] (dup x) [x] eq (prf x);
+             prf' : x' ≡ x : A =
+               δ 𝑖 ⇒ getω A (prf'-ω @𝑖) in
+        [(x', [prf'])]
+    } (δ 𝑖 ⇒ dup x)
+
+def drop-from-dup :
+    0.(A : ★) → (A → [ω.A]) → 0.(B : ★) → A → B → B =
+  λ A dup B x y ⇒ case dup x return B of { [_] ⇒ y }
+
+
 namespace sing {
 
 def val : 0.(A : ★) → 0.(x : A) → Sing A x → A =
@@ -107,4 +130,6 @@ def app : 0.(A B : ★) → 0.(x : A) →
   case sg return Sing B (f x) of { (x_, eq) ⇒
     case eq return Sing B (f x) of { [eq] ⇒ (f x_, [δ 𝑖 ⇒ f (eq @𝑖)]) }
   }
+
+
 }

lib/nat.quox

@@ -57,22 +57,31 @@ def elim-pairω :
       }
     }
 
-#[compile-scheme "(lambda (n) (cons n 'erased))"]
-def dup! : (n : ℕ) → [ω. Sing ℕ n] =
-  λ n ⇒
-  case n return n' ⇒ [ω. Sing ℕ n'] of {
-    zero ⇒ [(zero, [δ _ ⇒ zero])];
-    succ n, d ⇒
-      appω (Sing ℕ n) (Sing ℕ (succ n))
-        (λ n' ⇒ sing.app ℕ ℕ n (λ n ⇒ succ n) n') d
-  };
 
+def succ-boxω : [ω.ℕ] → [ω.ℕ] =
+  λ n ⇒ case n return [ω.ℕ] of { [n] ⇒ [succ n] }
+
+#[compile-scheme "(lambda (n) n)"]
 def dup : ℕ → [ω.ℕ] =
-  λ n ⇒ appω (Sing ℕ n) ℕ (λ n' ⇒ sing.val ℕ n n') (dup! n);
+  λ n ⇒ case n return [ω.ℕ] of {
+    0          ⇒ [0];
+    succ _, n! ⇒ succ-boxω n!
+  }
+
+def0 dup-ok : (n : ℕ) → dup n ≡ [n] : [ω.ℕ] =
+  λ n ⇒
+  case n return n' ⇒ dup n' ≡ [n'] : [ω.ℕ] of {
+    0          ⇒ δ 𝑖 ⇒ [0];
+    succ _, ih ⇒ δ 𝑖 ⇒ succ-boxω (ih @𝑖)
+  }
+
+def dup! : (n : ℕ) → [ω. Sing ℕ n] =
+  dup-from-parts ℕ dup dup-ok
+
 
-#[compile-scheme "(lambda% (n x) x)"]
 def drop : 0.(A : ★) → ℕ → A → A =
-  λ A n x ⇒ case n return A of { 0 ⇒ x; succ _, ih ⇒ ih }
+  drop-from-dup ℕ dup
+
 
 #[compile-scheme "(lambda% (m n) (+ m n))"]
 def plus : ℕ → ℕ → ℕ =

lib/string.quox

@@ -40,20 +40,16 @@ def eq? : DecEq Char =
     (nat.eq? (to-ℕ c) (to-ℕ d))
 
 def ws? : ω.Char → Bool =
-  λ c ⇒
+  λ c ⇒ bool.or (bool.or (eq c space) (eq c tab)) (eq c newline)
-  case dup c return Bool of { [c] ⇒
-    bool.or (bool.or (eq c space) (eq c tab)) (eq c newline)
-  }
 
 def digit? : ω.Char → Bool =
-  λ c ⇒ case dup c return Bool of { [c] ⇒
+  λ c ⇒ bool.and (ge c (from-ℕ 0x30)) (le c (from-ℕ 0x39))
-    bool.and (ge c (from-ℕ 0x30)) (le c (from-ℕ 0x39))
-  }
 
-def digit-val : Char → ℕ =
+def digit-val : Char → Maybe ℕ =
-  λ c ⇒
+  λ c ⇒ case dup c return Maybe ℕ of { [c] ⇒
-  case dup c return ℕ of { [c] ⇒
+    bool.if (Maybe ℕ) (digit? c)
-    bool.if ℕ (digit? c) (nat.minus (to-ℕ c) 0x30) 0
+      (Just ℕ (nat.minus (to-ℕ c) 0x30))
+      (Nothing ℕ)
   }
 
 }
@@ -77,13 +73,6 @@ def from-list : List Char → String =
 def foldl : 0.(A : ★) → A → ω.(A → Char → A) → String → A =
   λ A z f str ⇒ list.foldl Char A z f (to-list str)
 
-#[compile-scheme
-  "(lambda% (fail ok str) (cond [(string->number str) => ok] [else fail]))"]
-postulate to-ℕ' : 0.(B : ★) → ω.B → ω.(ℕ → B) → String → B
-
-def to-ℕ : String → Maybe ℕ =
-  to-ℕ' (Maybe ℕ) (Nothing ℕ) (Just ℕ)
-
 def split : ω.(ω.Char → Bool) → ω.String → List String =
   λ p str ⇒
     list.map (List Char) String from-list
@@ -103,4 +92,49 @@ postulate eq : ω.String → ω.String → Bool
 def null : ω.String → Bool = eq ""
 def not-null : ω.String → Bool = λ s ⇒ bool.not (null s)
 
+#[compile-scheme "(lambda (str) str)"]
+postulate dup : String → [ω.String]
+
+postulate0 dup-ok : (str : String) → dup str ≡ [str] : [ω.String]
+
+def dup! : (str : String) → Dup String str =
+  dup-from-parts String dup dup-ok
+
+
+def to-ℕ : String → Maybe ℕ =
+  letω add-digit : Maybe ℕ → ℕ → Maybe ℕ =
+    maybe.fold ℕ (ℕ → Maybe ℕ) (λ d ⇒ Just ℕ d)
+      (λ n d ⇒ Just ℕ (nat.plus (nat.times 10 n) d)) in
+  letω drop : Maybe ℕ → Maybe ℕ =
+    maybe.fold ℕ (Maybe ℕ) (Nothing ℕ)
+      (λ n ⇒ nat.drop (Maybe ℕ) n (Nothing ℕ)) in
+  letω add-digit-c : Maybe ℕ → Char → Maybe ℕ =
+    λ acc c ⇒
+      maybe.fold ℕ (Maybe ℕ → Maybe ℕ) drop (λ n acc ⇒ add-digit acc n)
+        (char.digit-val c) acc in
+  λ str ⇒
+    case dup str return Maybe ℕ of { [str] ⇒
+      bool.if (Maybe ℕ) (not-null str)
+        (foldl (Maybe ℕ) (Just ℕ 0) add-digit-c str)
+        (Nothing ℕ)
+    }
+
+def to-ℕ-or-0 : String → ℕ =
+  λ str ⇒ maybe.fold ℕ ℕ 0 (λ x ⇒ x) (to-ℕ str)
+
+
+#[compile-scheme
+ "(lambda% (yes no str)
+    (let [(len (string-length str))]
+      (if (= len 0)
+        no
+        (let [(first (string-ref str 0))
+              (rest  (substring str 1 len))]
+          (% yes first rest)))))"]
+postulate uncons' : 0.(A : ★) → ω.A → ω.(Char → String → A) → String → A
+
+def uncons : String → Maybe (Char × String) =
+  let0 Ret : ★ = Char × String in
+  uncons' (Maybe Ret) (Nothing Ret) (λ c s ⇒ Just Ret (c, s))
+
 }