more
This commit is contained in:
parent
b7f54594fb
commit
aa36cbfd63
|
|
@ -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 :
|
||||
|
|
@ -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).
|
||||
|
||||
*/
|
||||
2
day3.pl
2
day3.pl
|
|
@ -77,3 +77,5 @@ part2(File) :-
|
|||
bagof(R, gear(R), Rs),
|
||||
sum(Rs, Total),
|
||||
writeln(Total).
|
||||
|
||||
% vim: set ft=prolog :
|
||||
|
|
|
|||
24
day5.pl
24
day5.pl
|
|
@ -20,8 +20,7 @@ part(p(From, To, Elems)) -->
|
|||
header(From, To), blanks, blank_sep(map_line, Elems), blanks.
|
||||
|
||||
|
||||
file1(Seeds, Parts) -->
|
||||
seed_list(Seeds), blanks, many(part, Parts).
|
||||
file1(Seeds, 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 :
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
@ -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)))
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 → ℕ
|
||||
}
|
||||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
(let loop [(acc '()) (list (cdr list))]
|
||||
(if (pair? list)
|
||||
(loop (cons (car list) acc) (cdr list))
|
||||
(reverse acc))))"]
|
||||
"(lambda (lst)
|
||||
(do [(lst (cdr lst) (cdr lst))
|
||||
(acc '() (cons (car lst) acc))]
|
||||
[(equal? lst 'nil) (reverse acc)]))"]
|
||||
postulate to-scheme : 0.(A : ★) → List A → SchemeList A
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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 @𝑖)]) }
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
|
|
|||
33
lib/nat.quox
33
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 : ℕ → ℕ → ℕ =
|
||||
|
|
|
|||
|
|
@ -40,20 +40,16 @@ def eq? : DecEq Char =
|
|||
(nat.eq? (to-ℕ c) (to-ℕ d))
|
||||
|
||||
def ws? : ω.Char → Bool =
|
||||
λ c ⇒
|
||||
case dup c return Bool of { [c] ⇒
|
||||
bool.or (bool.or (eq c space) (eq c tab)) (eq c newline)
|
||||
}
|
||||
λ 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] ⇒
|
||||
bool.and (ge c (from-ℕ 0x30)) (le c (from-ℕ 0x39))
|
||||
}
|
||||
λ c ⇒ bool.and (ge c (from-ℕ 0x30)) (le c (from-ℕ 0x39))
|
||||
|
||||
def digit-val : Char → ℕ =
|
||||
λ c ⇒
|
||||
case dup c return ℕ of { [c] ⇒
|
||||
bool.if ℕ (digit? c) (nat.minus (to-ℕ c) 0x30) 0
|
||||
def digit-val : Char → Maybe ℕ =
|
||||
λ c ⇒ case dup c return Maybe ℕ of { [c] ⇒
|
||||
bool.if (Maybe ℕ) (digit? c)
|
||||
(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))
|
||||
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue