├── txt ├── day09 ├── day05 ├── day01 ├── day03 ├── day16 ├── day02.bis ├── day02 ├── day23 ├── day07 ├── day04 ├── day10 └── day16.bis ├── _CoqConfig.extras ├── lib.v ├── .gitignore ├── _CoqConfig ├── sol ├── day05_1.v ├── day05_2.v ├── day01_1.v ├── day02_2.v ├── day23_1.v ├── day16_1.v ├── day10_1.v ├── day09_1.v ├── day03_2.v ├── day07_1.v ├── day16_common.v ├── day16_2.v ├── day07_2.v ├── day04_1.v ├── day01_2.v ├── day02_1.v ├── day05_common.v └── day03_1.v ├── ephemeral_notes.md ├── lib ├── stream.v ├── grid.v ├── mock.v ├── utils.v ├── io.v ├── itree.v ├── string.v ├── mock_spec.v └── rel.v ├── Makefile ├── README.md └── SUMMARY.md /txt/day09: -------------------------------------------------------------------------------- 1 | 9 2 | 25 3 | -------------------------------------------------------------------------------- /_CoqConfig.extras: -------------------------------------------------------------------------------- 1 | lib/itree.v 2 | -------------------------------------------------------------------------------- /txt/day05: -------------------------------------------------------------------------------- 1 | dabAcCaCBAcCcaDA 2 | -------------------------------------------------------------------------------- /txt/day01: -------------------------------------------------------------------------------- 1 | +1 2 | -2 3 | +3 4 | +1 5 | -------------------------------------------------------------------------------- /txt/day03: -------------------------------------------------------------------------------- 1 | #1 @ 1,3: 4x4 2 | #2 @ 3,1: 4x4 3 | #3 @ 5,5: 2x2 4 | -------------------------------------------------------------------------------- /txt/day16: -------------------------------------------------------------------------------- 1 | Before: [3, 2, 1, 1] 2 | 9 2 1 2 3 | After: [3, 2, 2, 1] 4 | 5 | -------------------------------------------------------------------------------- /txt/day02.bis: -------------------------------------------------------------------------------- 1 | abcde 2 | fghij 3 | klmno 4 | pqrst 5 | fguij 6 | axcye 7 | wvxyz 8 | -------------------------------------------------------------------------------- /lib.v: -------------------------------------------------------------------------------- 1 | From advent.lib Require Export 2 | io mock rel string stream utils grid. 3 | -------------------------------------------------------------------------------- /txt/day02: -------------------------------------------------------------------------------- 1 | abcdef 2 | bababc 3 | abbcde 4 | abcccd 5 | aabcdd 6 | abcdee 7 | ababab 8 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | day*.ml 2 | day*.mli 3 | *.cmo 4 | *.cmi 5 | *.cmx 6 | *.native 7 | .lia.cache 8 | exe/ 9 | _CoqConfig.append 10 | _CoqProject 11 | -------------------------------------------------------------------------------- /_CoqConfig: -------------------------------------------------------------------------------- 1 | -Q . advent 2 | lib/string.v 3 | lib/stream.v 4 | lib/io.v 5 | lib/mock.v 6 | lib/mock_spec.v 7 | lib/rel.v 8 | lib/utils.v 9 | lib.v 10 | -------------------------------------------------------------------------------- /txt/day23: -------------------------------------------------------------------------------- 1 | pos=<0,0,0>, r=4 2 | pos=<1,0,0>, r=1 3 | pos=<4,0,0>, r=3 4 | pos=<0,2,0>, r=1 5 | pos=<0,5,0>, r=3 6 | pos=<0,0,3>, r=1 7 | pos=<1,1,1>, r=1 8 | pos=<1,1,2>, r=1 9 | pos=<1,3,1>, r=1 10 | -------------------------------------------------------------------------------- /txt/day07: -------------------------------------------------------------------------------- 1 | Step C must be finished before step A can begin. 2 | Step C must be finished before step F can begin. 3 | Step A must be finished before step B can begin. 4 | Step A must be finished before step D can begin. 5 | Step B must be finished before step E can begin. 6 | Step D must be finished before step E can begin. 7 | Step F must be finished before step E can begin. 8 | -------------------------------------------------------------------------------- /txt/day04: -------------------------------------------------------------------------------- 1 | [1518-11-01 00:00] Guard #10 begins shift 2 | [1518-11-01 00:05] falls asleep 3 | [1518-11-01 00:25] wakes up 4 | [1518-11-01 00:30] falls asleep 5 | [1518-11-01 00:55] wakes up 6 | [1518-11-01 23:58] Guard #99 begins shift 7 | [1518-11-02 00:40] falls asleep 8 | [1518-11-02 00:50] wakes up 9 | [1518-11-03 00:05] Guard #10 begins shift 10 | [1518-11-03 00:24] falls asleep 11 | [1518-11-03 00:29] wakes up 12 | [1518-11-04 00:02] Guard #99 begins shift 13 | [1518-11-04 00:36] falls asleep 14 | [1518-11-04 00:46] wakes up 15 | [1518-11-05 00:03] Guard #99 begins shift 16 | [1518-11-05 00:45] falls asleep 17 | [1518-11-05 00:55] wakes up 18 | -------------------------------------------------------------------------------- /sol/day05_1.v: -------------------------------------------------------------------------------- 1 | Set Warnings "-extraction-opaque-accessed". 2 | 3 | From Coq Require Import 4 | Ascii String List Arith 5 | OrderedTypeEx FMapAVL 6 | extraction.ExtrOcamlIntConv. 7 | Import ListNotations. 8 | 9 | From SimpleIO Require SimpleIO. 10 | 11 | From ExtLib Require Import 12 | Structures.Monads. 13 | Import MonadNotation. 14 | Local Open Scope monad. 15 | 16 | From advent Require Import lib sol.day05_common. 17 | 18 | Section main. 19 | 20 | Context {m : Type -> Type} `{Monad m} 21 | `{FoldRead int m} `{MonadO nat m}. 22 | 23 | Definition main : m unit := 24 | stack <- fold_read react_f [];; 25 | print (List.length stack). 26 | 27 | End main. 28 | 29 | Import SimpleIO. 30 | Definition exe : io_unit := IO.unsafe_run main. 31 | Extraction "day05_1.ml" exe. 32 | 33 | Section spec. 34 | 35 | End spec. 36 | -------------------------------------------------------------------------------- /txt/day10: -------------------------------------------------------------------------------- 1 | position=< 9, 1> velocity=< 0, 2> 2 | position=< 7, 0> velocity=<-1, 0> 3 | position=< 3, -2> velocity=<-1, 1> 4 | position=< 6, 10> velocity=<-2, -1> 5 | position=< 2, -4> velocity=< 2, 2> 6 | position=<-6, 10> velocity=< 2, -2> 7 | position=< 1, 8> velocity=< 1, -1> 8 | position=< 1, 7> velocity=< 1, 0> 9 | position=<-3, 11> velocity=< 1, -2> 10 | position=< 7, 6> velocity=<-1, -1> 11 | position=<-2, 3> velocity=< 1, 0> 12 | position=<-4, 3> velocity=< 2, 0> 13 | position=<10, -3> velocity=<-1, 1> 14 | position=< 5, 11> velocity=< 1, -2> 15 | position=< 4, 7> velocity=< 0, -1> 16 | position=< 8, -2> velocity=< 0, 1> 17 | position=<15, 0> velocity=<-2, 0> 18 | position=< 1, 6> velocity=< 1, 0> 19 | position=< 8, 9> velocity=< 0, -1> 20 | position=< 3, 3> velocity=<-1, 1> 21 | position=< 0, 5> velocity=< 0, -1> 22 | position=<-2, 2> velocity=< 2, 0> 23 | position=< 5, -2> velocity=< 1, 2> 24 | position=< 1, 4> velocity=< 2, 1> 25 | position=<-2, 7> velocity=< 2, -2> 26 | position=< 3, 6> velocity=<-1, -1> 27 | position=< 5, 0> velocity=< 1, 0> 28 | position=<-6, 0> velocity=< 2, 0> 29 | position=< 5, 9> velocity=< 1, -2> 30 | position=<14, 7> velocity=<-2, 0> 31 | position=<-3, 6> velocity=< 2, -1> 32 | -------------------------------------------------------------------------------- /ephemeral_notes.md: -------------------------------------------------------------------------------- 1 | (These notes need to be cleaned up into some write up somewhere.) 2 | 3 | --- 4 | 5 | For programs with so little interactivity, read/write might be too 6 | granular. So far all exercises fit the read_all pattern. To make 7 | things a bit more interesting and also more performant, I also try 8 | to use a finer fold_read pattern where possible. 9 | 10 | Day 5, part one, is a bit special about input handling: with 11 | byte-by-byte input you need to be careful about the newline character. 12 | Problems with less regular input might find read/write more useful. 13 | 14 | --- 15 | 16 | What even is a spec? 17 | 18 | - In day 1, part one, some might actually find the imperative style 19 | of [main] easier to understand than the recursive [sum_Z]. 20 | 21 | - In day 1, part two, the current spec basically says "if there is a 22 | duplicate, then [main] prints the first one". 23 | 24 | + we haven't proved that the existence of a duplicate 25 | implies [first_dup]; 26 | 27 | + How do we know the precondition is satified by our input? 28 | If it is not, then the spec tells us nothing. A better spec is: 29 | if [main] prints anything, it is the first duplicate. 30 | 31 | - In day 5, a naive approach is to only prove 32 | [fully_react input (react input)]. However I think the uniqueness 33 | of the solution is an important part of the problem, which motivates 34 | the proof of confluence. 35 | -------------------------------------------------------------------------------- /txt/day16.bis: -------------------------------------------------------------------------------- 1 | Before: [4, 4, 4, 4] 2 | 0 0 0 0 3 | After: [8, 4, 4, 4] 4 | 5 | Before: [5, 5, 5, 5] 6 | 1 2 1 0 7 | After: [6, 5, 5, 5] 8 | 9 | Before: [5, 5, 5, 5] 10 | 2 0 0 0 11 | After: [25, 5, 5, 5] 12 | 13 | Before: [5, 5, 5, 5] 14 | 3 0 3 0 15 | After: [15, 5, 5, 5] 16 | 17 | Before: [3, 4, 5, 6] 18 | 4 3 2 0 19 | After: [4, 4, 5, 6] 20 | 21 | Before: [3, 4, 5, 6] 22 | 5 3 2 0 23 | After: [2, 4, 5, 6] 24 | 25 | Before: [3, 4, 5, 6] 26 | 6 3 2 0 27 | After: [7, 4, 5, 6] 28 | 29 | Before: [3, 4, 5, 6] 30 | 7 3 3 0 31 | After: [7, 4, 5, 6] 32 | 33 | Before: [0, 0, 6, 3] 34 | 8 2 3 0 35 | After: [6, 0, 6, 3] 36 | 37 | Before: [0, 0, 0, 0] 38 | 9 2 3 0 39 | After: [2, 0, 0, 0] 40 | 41 | Before: [5, 5, 5, 2] 42 | 10 4 3 0 43 | After: [1, 5, 5, 2] 44 | 45 | Before: [5, 5, 5, 6] 46 | 11 3 4 0 47 | After: [1, 5, 5, 6] 48 | 49 | Before: [5, 5, 5, 6] 50 | 12 3 2 0 51 | After: [1, 5, 5, 6] 52 | 53 | Before: [5, 5, 5, 2] 54 | 13 5 2 0 55 | After: [1, 5, 5, 2] 56 | 57 | Before: [5, 5, 5, 2] 58 | 14 2 5 0 59 | After: [1, 5, 5, 2] 60 | 61 | Before: [3, 3, 3, 3] 62 | 15 2 2 0 63 | After: [1, 3, 3, 3] 64 | 65 | 9 1 0 0 66 | 9 2 0 1 67 | 9 3 0 1 68 | 9 4 0 1 69 | 0 1 2 0 70 | 1 0 3 0 71 | 2 0 1 0 72 | 3 0 3 0 73 | 4 0 0 0 74 | 5 0 15 0 75 | 6 0 0 0 76 | 7 0 0 0 77 | 8 0 0 1 78 | 10 0 1 3 79 | 0 0 3 0 80 | 11 0 1 3 81 | 0 0 3 0 82 | 12 0 1 3 83 | 0 0 3 0 84 | 13 0 1 3 85 | 0 0 3 0 86 | 14 0 1 3 87 | 0 0 3 0 88 | 15 0 1 3 89 | 0 0 3 0 90 | 0 0 1 0 91 | -------------------------------------------------------------------------------- /sol/day05_2.v: -------------------------------------------------------------------------------- 1 | Set Warnings "-extraction-opaque-accessed". 2 | 3 | From Coq Require Import 4 | Ascii String List Arith NArith 5 | OrderedTypeEx FMapAVL 6 | extraction.ExtrOcamlIntConv. 7 | Import ListNotations. 8 | 9 | From SimpleIO Require SimpleIO. 10 | 11 | From ExtLib Require Import 12 | Structures.Monads. 13 | Import MonadNotation. 14 | Local Open Scope monad. 15 | 16 | From advent Require Import lib sol.day05_common. 17 | 18 | Import SimpleIO. 19 | 20 | Definition polymer_length : list int -> int := 21 | fun cs => int_of_nat (List.length (rev_react cs)). 22 | 23 | Definition purge (i : int) : list int -> list int := 24 | filter (fun c => int_neqb c i && negb (reactable c i))%bool. 25 | 26 | Section main. 27 | 28 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} 29 | `{MonadI int m} `{MonadO int m}. 30 | 31 | Definition minimum_in (f : int -> int) (i j : int) : m int := 32 | mfix (fun self '(i, best) => 33 | if int_eqb i j then 34 | ret best 35 | else 36 | let y := f i in 37 | let i' := (i + int_of_nat 1)%int in 38 | if int_lt y best then 39 | self (i', y) 40 | else 41 | self (i', best)) ((i + int_of_nat 1)%int, f i). 42 | 43 | Definition main : m unit := 44 | cs <- read_all;; 45 | z <- minimum_in (fun i => polymer_length (purge i cs)) 46 | (int_of_n 65) (int_of_n 91);; 47 | print z. 48 | 49 | End main. 50 | 51 | Definition exe : io_unit := IO.unsafe_run main. 52 | Extraction "day05_2.ml" exe. 53 | -------------------------------------------------------------------------------- /lib/stream.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List Streams. 3 | Import ListNotations. 4 | 5 | Fixpoint Str_take {A : Type} (n : nat) (xs : Stream A) : list A := 6 | match n, xs with 7 | | O, _ => []%list 8 | | S n, Cons x xs => x :: Str_take n xs 9 | end. 10 | 11 | CoFixpoint Str_scanl {A B : Type} 12 | (f : B -> A -> B) (y : B) (xs : Stream A) : Stream B := 13 | Cons y (match xs with 14 | | Cons x xs => Str_scanl f (f y x) xs 15 | end). 16 | 17 | (* Properties *) 18 | 19 | Lemma Str_nth_S {A : Type} (n : nat) (xs : Stream A) : 20 | Str_nth (S n) xs = Str_nth n (tl xs). 21 | Proof. auto. Qed. 22 | 23 | Lemma Str_nth_tl_S {A : Type} (n : nat) (xs : Stream A) : 24 | Str_nth_tl (S n) xs = tl (Str_nth_tl n xs). 25 | Proof. 26 | revert xs; induction n; auto; intros. 27 | simpl; rewrite <- IHn; auto. 28 | Qed. 29 | 30 | Lemma Str_take_S {A : Type} (n : nat) (xs : Stream A) : 31 | Str_take (S n) xs = Str_take n xs ++ [Str_nth n xs]. 32 | Proof. 33 | revert xs; induction n; intros []; auto. 34 | simpl; rewrite <- IHn; auto. 35 | Qed. 36 | 37 | Lemma Str_scanl_S {A B : Type} (n : nat) (f : B -> A -> B) 38 | (y : B) (xs : Stream A) : 39 | Str_nth (S n) (Str_scanl f y xs) = 40 | f (Str_nth n (Str_scanl f y xs)) (Str_nth n xs). 41 | Proof. 42 | revert xs; revert y; induction n; intros; destruct xs; cbn; auto. 43 | - repeat rewrite Str_nth_S; simpl. rewrite <- IHn; auto. 44 | Qed. 45 | 46 | Lemma Str_scanl_nth {A B : Type} 47 | (f : B -> A -> B) (y : B) (xs : Stream A) 48 | (n : nat) : 49 | Str_nth n (Str_scanl f y xs) = fold_left f (Str_take n xs) y. 50 | Proof. 51 | revert xs. revert y. 52 | induction n; intros; destruct xs as [x xs]. 53 | - auto. 54 | - simpl; rewrite <- IHn; auto. 55 | Qed. 56 | -------------------------------------------------------------------------------- /sol/day01_1.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List ZArith Ascii String 3 | extraction.ExtrOcamlIntConv. 4 | Import ListNotations. 5 | 6 | From SimpleIO Require SimpleIO. 7 | 8 | From ExtLib Require Import 9 | Structures.Monads. 10 | Import MonadNotation. 11 | Local Open Scope monad. 12 | 13 | From advent Require Import lib. 14 | 15 | Section main. 16 | 17 | Context {m : Type -> Type} `{Monad m} 18 | `{FoldRead Z m} `{MonadO Z m}. 19 | 20 | (* Read integers and accumulate their sum. *) 21 | Definition main : m unit := 22 | fold_read (fun z0 z => z0 + z)%Z 0%Z >>= print. 23 | 24 | End main. 25 | 26 | Import SimpleIO. 27 | 28 | Definition exec : io_unit := IO.unsafe_run main. 29 | 30 | Extraction "day01_1.ml" exec. 31 | 32 | 33 | Section spec. 34 | 35 | (* Sum of a list of numbers. *) 36 | Fixpoint sum_Z (zs : list Z) : Z := 37 | match zs with 38 | | [] => 0 39 | | z :: zs => z + sum_Z zs 40 | end. 41 | 42 | Lemma sum_Z_fold (zs : list Z) : 43 | sum_Z zs = fold_left Z.add zs 0%Z. 44 | Proof. 45 | assert 46 | (H : forall zs z0, fold_left Z.add zs z0 = (z0 + sum_Z zs)%Z). 47 | - clear. induction zs; intro z; simpl. 48 | + rewrite Z.add_0_r. auto. 49 | + rewrite Z.add_assoc. auto. 50 | - rewrite H; auto. 51 | Qed. 52 | 53 | (* If you run [main] with the input [zs], then the printed output 54 | will be exactly [sum_Z zs]. *) 55 | Definition correct (main : io_rel Z Z unit) : Prop := 56 | forall zs, rel_spec Z Z main zs [sum_Z zs]. 57 | 58 | Theorem correct_main : correct main. 59 | Proof. 60 | intros zs. 61 | unfold rel_spec. 62 | exists (Mk_io_state [] [sum_Z zs]); split; [| auto]. 63 | exists (sum_Z zs); eexists. 64 | split. 65 | - apply fold_read_rel. 66 | split; [| reflexivity]. 67 | apply sum_Z_fold. 68 | - hnf; auto. 69 | Qed. 70 | 71 | End spec. 72 | -------------------------------------------------------------------------------- /lib/grid.v: -------------------------------------------------------------------------------- 1 | (* A simple library for representing and displaying points on a 2 | grid. *) 3 | 4 | From Coq Require Import 5 | List ZArith FMapAVL OrderedTypeEx. 6 | Import ListNotations. 7 | 8 | Module ZMap := FMapAVL.Make Z_as_OT. 9 | 10 | (* First index by [y] then [x]. So it can be more efficiently 11 | displayed line by line. *) 12 | Variant Grid (A : Type) : Type := 13 | | MkGrid : ZMap.t (ZMap.t A) -> Grid A 14 | . 15 | 16 | Arguments MkGrid {A}. 17 | 18 | Definition empty_grid (A : Type) : Grid A := 19 | MkGrid (ZMap.empty _). 20 | 21 | Module GridZ. 22 | 23 | Definition index {A : Type} (g : Grid A) (y x : Z) : option A := 24 | let '(MkGrid g) := g in 25 | match ZMap.find y g with 26 | | None => None 27 | | Some gy => ZMap.find x gy 28 | end. 29 | 30 | (* Index with a default value. *) 31 | Definition index' {A : Type} (a : A) (g : Grid A) (y x : Z) : A := 32 | match index g y x with 33 | | None => a 34 | | Some a' => a' 35 | end. 36 | 37 | Definition insert {A : Type} (y x : Z) (a : A) (g : Grid A) : Grid A := 38 | let '(MkGrid g) := g in 39 | let gy := 40 | match ZMap.find y g with 41 | | None => ZMap.empty _ 42 | | Some gy => gy 43 | end in 44 | MkGrid (ZMap.add y (ZMap.add x a gy) g). 45 | 46 | Definition forZ {A : Type} 47 | (z_min z_iter : Z) (f : Z -> A) : list A := 48 | snd (Z.iter z_iter (fun '(z', xs) => 49 | let z' := Z.pred z' in 50 | (z', f z' :: xs)) ((z_min + z_iter)%Z, [])). 51 | 52 | Example forZ_ex : forZ (-1) 3 (fun x => x) = [-1; 0; 1]%Z. 53 | Proof. reflexivity. Qed. 54 | 55 | Definition render {A : Type} (a : A) 56 | (y_min y_height x_min x_width : Z) 57 | (g : Grid A) 58 | : list (list A) := 59 | forZ y_min y_height (fun y => 60 | forZ x_min x_width (fun x => 61 | index' a g y x)). 62 | 63 | End GridZ. 64 | -------------------------------------------------------------------------------- /sol/day02_2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List Arith Ascii String 3 | OrderedTypeEx FMapAVL 4 | extraction.ExtrOcamlIntConv. 5 | Import ListNotations. 6 | 7 | From SimpleIO Require SimpleIO. 8 | 9 | From ExtLib Require Import 10 | Structures.Monads. 11 | Import MonadNotation. 12 | Local Open Scope monad. 13 | 14 | From advent Require Import lib. 15 | 16 | Section algorithm. 17 | 18 | Context {A : Type} (eqb : A -> A -> bool). 19 | 20 | (* [distance_one eqb xs xs']: when [xs] and [xs'] differ on 21 | exactly one element at the same position, the result is the list 22 | of elements common to [xs] and [xs'], in order. *) 23 | 24 | Fixpoint distance_one_aux 25 | (acc : list A) (xs xs' : list A) : option (list A) := 26 | match xs, xs' with 27 | | x :: xs, x' :: xs' => 28 | if eqb x x' then 29 | distance_one_aux (x :: acc) xs xs' 30 | else if eqb_list eqb xs xs' then 31 | Some (rev' acc ++ xs) 32 | else 33 | None 34 | | _, _ => None 35 | end. 36 | 37 | Definition distance_one (xs xs' : list A) : option (list A) := 38 | distance_one_aux [] xs xs'. 39 | 40 | Fixpoint search (xss : list (list A)) : option (list A) := 41 | match xss with 42 | | [] => None 43 | | xs :: xss => 44 | match find_some (distance_one xs) xss with 45 | | Some ys => Some ys 46 | | None => search xss 47 | end 48 | end. 49 | 50 | End algorithm. 51 | 52 | Section main. 53 | 54 | Context {m : Type -> Type} `{Monad m} `{MonadError m} 55 | `{MonadI (list ascii) m} `{MonadO (list ascii) m} 56 | `{MonadFix m}. 57 | 58 | Definition main : m unit := 59 | ids <- read_all;; 60 | match search eqb_ascii ids with 61 | | Some s => print s 62 | | None => error "Close IDs not found" 63 | end. 64 | 65 | End main. 66 | 67 | Import SimpleIO. 68 | 69 | Definition exec : io_unit := IO.unsafe_run main. 70 | 71 | Extraction "day02_2.ml" exec. 72 | -------------------------------------------------------------------------------- /sol/day23_1.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | String List ZArith 3 | extraction.ExtrOcamlIntConv. 4 | Import ListNotations. 5 | 6 | From ExtLib Require Import 7 | Structures.Monad. 8 | Import MonadNotation. 9 | Local Open Scope monad. 10 | 11 | From SimpleIO Require Import SimpleIO. 12 | 13 | From advent Require Import lib. 14 | 15 | Inductive nanobot : Type := Nanobot (x y z r : Z). 16 | 17 | Parameter read_nanobot' : 18 | forall r : Type, (int -> int -> int -> int -> r) -> IO r. 19 | Extract Constant read_nanobot' => " 20 | fun f k -> 21 | k (Scanf.scanf ""pos=<%d,%d,%d>, r=%d "" f)". 22 | 23 | Definition read_nanobot : IO (option nanobot) := 24 | catch_eof (read_nanobot' _ (fun x y z r => 25 | Nanobot (z_of_int x) (z_of_int y) (z_of_int z) 26 | (z_of_int r))). 27 | 28 | Definition range_lt : nanobot -> nanobot -> bool := 29 | fun '(Nanobot _ _ _ r1) '(Nanobot _ _ _ r2) => 30 | (r1 ns0 36 | | n :: ns => 37 | let ns0 := 38 | match ns0 with 39 | | [] => [n] 40 | | n0 :: _ => if range_lt n0 n then [n] else ns0 41 | end 42 | in find_max_range' ns0 ns 43 | end. 44 | 45 | Definition find_max_range : list nanobot -> list nanobot := 46 | find_max_range' []. 47 | 48 | (* [in_range n0 n1]: nanobot [n1] is within range of nanobot [n0]. *) 49 | Definition in_range : nanobot -> nanobot -> bool := 50 | fun '(Nanobot x0 y0 z0 r0) '(Nanobot x1 y1 z1 _) => 51 | (Z.abs (x0 - x1) + Z.abs (y0 - y1) + Z.abs (z0 - z1) <=? r0)%Z. 52 | 53 | Section main. 54 | 55 | Context {m : Type -> Type} `{Monad m} `{MonadError m} 56 | `{FoldRead nanobot m} `{MonadO nat m}. 57 | 58 | Definition main : m unit := 59 | ps <- read_all;; 60 | match find_max_range ps with 61 | | [] => error "no nanobots" 62 | | _ :: _ :: _ => error "no unique max-range nanobot" 63 | | [n0] => 64 | print (length (filter (in_range n0) ps)) 65 | end. 66 | 67 | End main. 68 | 69 | Instance MonadI_nanobot_IO : MonadI nanobot IO := { 70 | read := read_nanobot; 71 | }. 72 | 73 | Definition exe : io_unit := IO.unsafe_run main. 74 | Extraction "day23_1.ml" exe. 75 | -------------------------------------------------------------------------------- /lib/mock.v: -------------------------------------------------------------------------------- 1 | (* Mocking the IO interface with pure functions. *) 2 | 3 | From Coq Require Import 4 | List ZArith 5 | extraction.ExtrOcamlIntConv. 6 | Import ListNotations. 7 | 8 | From Coq.extraction Require Import 9 | ExtrOcamlIntConv. 10 | 11 | From ExtLib Require Import 12 | Data.Monads.OptionMonad 13 | Structures.Monads. 14 | 15 | From advent.lib Require Import 16 | io. 17 | 18 | Definition input : Type := list Z. 19 | Definition output : Type := list Z. 20 | 21 | Record mock (r : Type) (a : Type) : Type := Mk_mock { 22 | un_mock : 23 | (a -> output -> input (* remaining *) -> r) -> 24 | input -> 25 | r; 26 | }. 27 | 28 | Arguments Mk_mock {r a} _. 29 | Arguments un_mock {r a} _. 30 | 31 | Global Instance Monad_mock r : Monad (mock r) := { 32 | ret _ a := Mk_mock (fun k => k a []); 33 | bind _ _ m k := Mk_mock (fun q => 34 | un_mock m (fun a o => 35 | un_mock (k a) (fun a o' => 36 | q a (o ++ o')))); 37 | }. 38 | 39 | Global Instance MonadIZ_mock r : MonadI Z (mock r) := { 40 | read := Mk_mock (fun k zs => 41 | match zs with 42 | | [] => k None [] [] 43 | | z :: zs => k (Some z) [] zs 44 | end); 45 | }. 46 | 47 | Global Instance MonadOZ_mock r : MonadO Z (mock r) := { 48 | print z := Mk_mock (fun k zs => k tt [] [z]); 49 | }. 50 | 51 | (* Fuel for [mfix] *) 52 | Definition fuelT (m : Type -> Type) a := 53 | nat -> m (option a). 54 | 55 | Import MonadNotation. 56 | Local Open Scope monad_scope. 57 | 58 | Instance Monad_fuelT (m : Type -> Type) 59 | `{Monad m} : Monad (fuelT m) := { 60 | ret _ a := fun _ => Monad.ret (Some a); 61 | bind _ _ m k := fun fuel => 62 | o <- m fuel;; 63 | match o with 64 | | None => Monad.ret None 65 | | Some a => k a fuel 66 | end; 67 | }. 68 | 69 | Instance MonadFix_fuelT (m : Type -> Type) 70 | `{Monad m} : MonadFix (fuelT m) := { 71 | mfix _ _ gf := fun a fuel0 => 72 | (fix go fuel a := 73 | match fuel with 74 | | O => Monad.ret None 75 | | S fuel' => gf (fun a _ => go fuel' a) a fuel0 76 | end) fuel0 a 77 | }. 78 | 79 | Instance MonadIZ_fuelT I (m : Type -> Type) 80 | `{Monad m} `{MonadI I m} : MonadI I (fuelT m) := { 81 | read := fun _ => liftM Some read; 82 | }. 83 | 84 | Instance MonadOZ_fuelT O (m : Type -> Type) 85 | `{Monad m} `{MonadO O m} : MonadO O (fuelT m) := { 86 | print z := fun _ => liftM Some (print z); 87 | }. 88 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | .PHONY: all test-all lib clean 2 | 3 | all: \ 4 | exe/day01_1 exe/day01_2 \ 5 | exe/day02_1 exe/day02_2 \ 6 | exe/day03_1 exe/day03_2 \ 7 | exe/day04_1 \ 8 | exe/day05_1 exe/day05_2 \ 9 | exe/day07_1 exe/day07_2 \ 10 | exe/day09_1 \ 11 | exe/day10_1 \ 12 | exe/day16_1 exe/day16_2 13 | 14 | exe: 15 | mkdir exe/ 16 | 17 | test-all: all 18 | ./exe/day01_1 < ./txt/day01 19 | @echo "3 < Expected output" 20 | ./exe/day01_2 < ./txt/day01 21 | @echo "2 < Expected output" 22 | 23 | ./exe/day02_1 < ./txt/day02 24 | @echo "12 < Expected output" 25 | ./exe/day02_1 < ./txt/day02.bis 26 | ./exe/day02_2 < ./txt/day02 27 | ./exe/day02_2 < ./txt/day02.bis 28 | @echo "fgij < Expected output" 29 | 30 | ./exe/day03_1 < ./txt/day03 31 | @echo "4 < Expected output" 32 | ./exe/day03_2 < ./txt/day03 33 | @echo "3 < Expected output" 34 | 35 | ./exe/day04_1 < ./txt/day04 36 | @echo "240 < Expected output" 37 | @echo "TODO day04_2" 38 | @echo "4455 < Expected output" 39 | 40 | ./exe/day05_1 < ./txt/day05 41 | @echo "10 < Expected output" 42 | ./exe/day05_2 < ./txt/day05 43 | @echo "4 < Expected output" 44 | 45 | ./exe/day07_1 < ./txt/day07 46 | @echo "CABDFE < Expected output" 47 | ./exe/day07_2 < ./txt/day07 48 | @echo "253 < Expected output" 49 | 50 | ./exe/day09_1 < ./txt/day09 51 | @echo "32 < Expected output" 52 | 53 | echo -e "3\n0\n10\n0\n8"|cat - txt/day10|./exe/day10_1 54 | @echo "(Should spell HI)" 55 | 56 | ./exe/day16_1 < ./txt/day16 57 | @echo "1 < Expected output" 58 | ./exe/day16_2 < ./txt/day16.bis 59 | @echo "10 < Expected output" 60 | 61 | lib: Makefile.coq 62 | $(MAKE) -f Makefile.coq 63 | 64 | Makefile.coq: _CoqProject 65 | coq_makefile -f _CoqProject -o $@ 66 | 67 | exe/%: exe sol/%.vo 68 | ocamlopt -I sol/ sol/$*.mli sol/$*.ml -o $@ 69 | 70 | .PRECIOUS: sol/%.vo 71 | sol/%.vo: lib sol/%.v 72 | cd sol/ ; coqc -Q .. advent $*.v 73 | 74 | sol/day05_1.vo sol/day05_2.vo: sol/day05_common.vo 75 | 76 | sol/day16_1.vo sol/day16_2.vo: sol/day16_common.vo 77 | 78 | # ln -s _CoqConfig.append _CoqConfig.extras 79 | _CoqConfig.append: 80 | touch $@ 81 | 82 | _CoqProject: _CoqConfig _CoqConfig.append 83 | cat _CoqConfig _CoqConfig.append > _CoqProject 84 | 85 | clean: 86 | $(RM) -r exe/ 87 | $(RM) sol/day*.ml{i,} {*,.}/*.{glob,vo,cmi,cmx,cmo,o} {*,.}/.*.aux {*,.}/.lia.cache .coqdeps.d Makefile.coq Makefile.coq.conf 88 | -------------------------------------------------------------------------------- /sol/day16_1.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | String List Arith ZArith 3 | extraction.ExtrOcamlIntConv. 4 | Import ListNotations. 5 | 6 | From ExtLib.Structures Require Import 7 | Monad MonadFix. 8 | 9 | From SimpleIO Require SimpleIO. 10 | 11 | From advent Require Import lib sol.day16_common. 12 | 13 | Module Import DB. 14 | Import SimpleIO. 15 | (* TODO send to simple-io. *) 16 | Definition debug_switch := false. (* Switch this to [true] for debug 17 | output. *) 18 | Parameter debug' : forall {A}, ocaml_string -> ocaml_string -> A -> A. 19 | Extract Constant debug' => "fun s n x -> Printf.printf ""%s: %s\n"" s n; x". 20 | Definition debug : forall {A}, string -> string -> A -> A := 21 | fun _ s n => 22 | if debug_switch then debug' (to_ostring s) (to_ostring s) 23 | else fun x => x. 24 | End DB. 25 | 26 | Section main. 27 | 28 | Import MonadNotation. 29 | Local Open Scope monad_scope. 30 | 31 | Definition sample_ (regs : Type) : Type := 32 | regs * Z * Z * Z * regs. 33 | 34 | Definition sample : Type := sample_ regs. 35 | 36 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} 37 | `{FoldRead sample m} `{MonadO N m}. 38 | 39 | Definition plausibles : sample -> list op := 40 | fun '(rs, a, b, c, rs') => 41 | filter 42 | (fun o => 43 | let is := (o, a, b, c) in 44 | let b := (wf is && eqb_reg (interp is rs) rs')%bool in 45 | debug (if b then "Y" else "N") (show_op o) b 46 | ) 47 | all_ops. 48 | 49 | Definition count_3plausibles : m N := 50 | fold_read 51 | (fun n s => 52 | if 3 <=? length (plausibles s) then (1 + n)%N else n%N 53 | ) 0%N. 54 | 55 | Definition main : m unit := (count_3plausibles >>= print). 56 | 57 | End main. 58 | 59 | Import SimpleIO. 60 | 61 | Parameter parse_sample : forall {regs}, 62 | (int -> int -> int -> int -> regs) -> 63 | (int -> Z) -> 64 | IO (option (sample_ regs)). 65 | Extract Constant parse_sample => " 66 | fun regs z k -> 67 | k (try 68 | Scanf.scanf 69 | ""Before: [%d, %d, %d, %d] %_d %d %d %d After: [%d, %d, %d, %d] "" 70 | (fun r0 r1 r2 r3 a b c s0 s1 s2 s3 -> 71 | Some ((((regs r0 r1 r2 r3, z a), z b), z c), regs s0 s1 s2 s3)) with Scanf.Scan_failure _ | End_of_file -> None 72 | )". 73 | 74 | Definition read_sample : IO (option sample) := 75 | let z := z_of_int in 76 | let Regs' r0 r1 r2 r3 := Regs (z r0) (z r1) (z r2) (z r3) in 77 | parse_sample Regs' z. 78 | 79 | Local Instance MonadI_sample_IO : MonadI sample IO := 80 | read_sample. 81 | 82 | Definition exe : io_unit := IO.unsafe_run main. 83 | Extraction "day16_1.ml" exe. 84 | -------------------------------------------------------------------------------- /sol/day10_1.v: -------------------------------------------------------------------------------- 1 | (* Inputs, first five integers on each line: 2 | 3 | - time to predict; 4 | - [x_min] 5 | - [x_width] 6 | - [y_min] 7 | - [y_height] 8 | 9 | Followed by the actual problem input. 10 | 11 | Some trial and error is still necessary to find the right area. 12 | 13 | TODO: automate, e.g., pick two arbitrary points and find when 14 | they are close. 15 | *) 16 | 17 | From Coq Require Import 18 | Ascii String 19 | List NArith ZArith 20 | extraction.ExtrOcamlIntConv. 21 | Import ListNotations. 22 | 23 | From ExtLib Require Import 24 | Structures.Monad 25 | Structures.MonadFix. 26 | 27 | From SimpleIO Require Import SimpleIO IO_Unsafe. 28 | 29 | From advent Require Import lib. 30 | 31 | (* Throws exceptions! *) 32 | Parameter parse : forall {P V : Type}, 33 | (int -> int -> P) -> 34 | (int -> int -> V) -> 35 | ocaml_string -> (P * V). 36 | Extract Constant parse => 37 | "fun point velo s -> 38 | Scanf.sscanf s ""position=< %d , %d > velocity=< %d , %d >"" 39 | (fun px py vx vy -> (point px py, velo vx vy))". 40 | 41 | Section main. 42 | Import MonadNotation. 43 | Local Open Scope monad. 44 | 45 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} `{MonadError m} 46 | `{MonadI ocaml_string m} 47 | `{MonadO ocaml_string m}. 48 | 49 | Definition do_read {A : Type} (f : ocaml_string -> A) : m A := 50 | ox <- read;; 51 | match ox with 52 | | None => error "oops" 53 | | Some x => ret (f x) 54 | end. 55 | 56 | Definition pair_Z : int -> int -> Z * Z := 57 | fun x y => (z_of_int x, z_of_int y). 58 | 59 | Definition parse_Z : ocaml_string -> Z := 60 | fun s => z_of_int (unsafe_int_of_ostring s). 61 | 62 | Definition predict_grid {A : Type} (a : A) 63 | (t : Z) (ps : list ((Z * Z) * (Z * Z))) : Grid A := 64 | fold_left 65 | (fun g p => 66 | match p with 67 | | ((x, y), (vx, vy)) => 68 | GridZ.insert (y + t * vy) (x + t * vx) a g 69 | end) 70 | ps 71 | (empty_grid A). 72 | 73 | Definition main : m unit := 74 | t <- do_read parse_Z;; 75 | x_min <- do_read parse_Z;; 76 | x_width <- do_read parse_Z;; 77 | y_min <- do_read parse_Z;; 78 | y_height <- do_read parse_Z;; 79 | lines <- read_all;; 80 | let points : list ((Z * Z) * (Z * Z)) := map (parse pair_Z pair_Z) lines in 81 | let g := predict_grid (char_of_ascii "#") t points in 82 | for' (GridZ.render (char_of_ascii ".") 83 | y_min y_height x_min x_width g) 84 | (fun line => 85 | print (OString.of_list line)). 86 | 87 | End main. 88 | 89 | Import SimpleIO. 90 | Definition exe : io_unit := IO.unsafe_run main. 91 | Extraction "day10_1.ml" exe. 92 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Advent of Code 2018 in Coq 2 | ========================== 3 | 4 | This repository contains solutions for the Advent of Code 2018 5 | (https://adventofcode.com/2018). Some of them are formally verified. 6 | This is an example of applying verification to small programming 7 | challenges of that kind. 8 | (If you're aiming for prizes, this is probably not the way to go.) 9 | 10 | Contributions welcome 11 | --------------------- 12 | 13 | It will probably take much longer than the actual span of the AoC to 14 | complete this project, so any help implementing, specifying, or verifying 15 | solutions is welcome. If you have any questions, open an issue or send 16 | me an email (lysxia@gmail.com). 17 | 18 | ### Suggested tasks 19 | 20 | - `day02_2.v`, `day03_2.v` are bare of any verification effort. 21 | 22 | - Implement Day 6 (Manhattan geometry). 23 | 24 | Project status 25 | -------------- 26 | 27 | As of December 2, the two solutions of Day 1's challenge are 28 | verified (significant caveats apply). 29 | 30 | Read more about my approach in [`SUMMARY.md`](./SUMMARY.md). 31 | 32 | Dependencies 33 | ------------ 34 | 35 | - [coq-simple-io](https://github.com/Lysxia/coq-simple-io), master 36 | 37 | This project serves to test coq-simple-io and see what is missing to 38 | make it practical to write executable programs in Coq. 39 | 40 | - [coq-ext-lib](https://github.com/coq-ext-lib/coq-ext-lib), 0.10 41 | 42 | - [Coq](https://coq.inria.fr/), 8.8.2 43 | 44 | - [OCaml](https://ocaml.org), 4.07.0 45 | 46 | Older versions of these are likely to work. 47 | 48 | ### Optional dependency 49 | 50 | - [coq-itree](https://github.com/DeepSpec/InteractionTrees), master. 51 | A library of free monads and algebraic effects (WIP). 52 | 53 | Experimental proofs using `itree` instead of `io_rel` can be found in 54 | files `sol/day*_*_extra.v`. 55 | 56 | To install coq-itree with opam and make it known to advent-of-coq: 57 | 58 | ```sh 59 | git clone https://github.com/DeepSpec/InteractionTrees 60 | opam pin add coq-itree ./InteractionTrees 61 | 62 | # Inside advent-of-coq-2018, create a symbolic link _CoqConfig.append 63 | # to _CoqConfig.extras 64 | # The -f option overwrites any existing _CoqConfig.append 65 | ln -sf _CoqConfig.extras _CoqConfig.append 66 | 67 | # (Re)generate _CoqProject and compile lib.itree 68 | make lib 69 | ``` 70 | 71 | Install the development version of coq-simple-io with opam 72 | ---------------------------------------------------------- 73 | 74 | ```sh 75 | # Get the source 76 | git clone https://github.com/Lysxia/coq-simple-io 77 | 78 | # Register the local version of coq-simple-io with opam 79 | opam pin add -k git coq-simple-io ./coq-simple-io 80 | 81 | # When coq-simple-io is updated 82 | cd coq-simple-io && git pull coq-simple-io 83 | opam reinstall coq-simple-io 84 | ``` 85 | 86 | Build 87 | ----- 88 | 89 | To compile and run `day01_1.v` for example: 90 | 91 | ```sh 92 | make exe/day01_1 93 | ./exe/day01_1 < txt/day01 94 | ``` 95 | -------------------------------------------------------------------------------- /sol/day09_1.v: -------------------------------------------------------------------------------- 1 | (* This is actually the solution to both parts one and two 2 | (since the only difference is the scale of inputs). 3 | 4 | The expected input format is two lines, the number of players 5 | followed by the number of marbles (so you had to edit the 6 | provided input (a sentence) a little). 7 | *) 8 | 9 | From Coq Require Import 10 | List NArith String. 11 | Import ListNotations. 12 | 13 | From ExtLib Require Import 14 | Structures.Monad. 15 | 16 | From SimpleIO Require Import SimpleIO. 17 | 18 | From advent Require Import lib. 19 | 20 | Definition Zipper : Type := list N * list N. 21 | 22 | Definition go_right : Zipper -> Zipper := fun z => 23 | match z with 24 | | (l, []) => 25 | match rev' l with 26 | | [] => ([], []) 27 | | x :: r' => ([x], r') 28 | end 29 | | (l, x :: r') => (x :: l, r') 30 | end. 31 | 32 | Definition go_left : Zipper -> Zipper := fun z => 33 | match z with 34 | | ([], r) => 35 | match rev' r with 36 | | [] => ([], []) 37 | | x :: l' => (l', [x]) 38 | end 39 | | (x :: l', r) => (l', x :: r) 40 | end. 41 | 42 | Record Board : Type := MkBoard { 43 | players : Zipper; 44 | marbles : Zipper; 45 | }. 46 | 47 | (* clockwise = rightwards *) 48 | 49 | Definition turn (next_marble : N) (board : Board) : Board := 50 | let '(MkBoard ps ms) := board in 51 | if (N.modulo next_marble 23 =? 0)%N then 52 | (* We go one more step to put the 7th marble on the 53 | right half of the zipper *) 54 | match N.iter 8 go_left ms, ps with 55 | | (_, []), _ | _, ([], _) => board (* should not happen *) 56 | | (l, x :: r), (p :: pl, pr) => 57 | {| players := (go_right ((next_marble + x + p)%N :: pl, pr)); 58 | marbles := go_right (l, r); 59 | |} 60 | end 61 | else 62 | match go_right ms with 63 | | (l, r) => 64 | {| players := go_right ps; 65 | marbles := (next_marble :: l, r); 66 | |} 67 | end. 68 | 69 | Definition play (n_players max_marble : N) : Board := 70 | snd (N.iter 71 | max_marble 72 | (fun '(next, bd) => 73 | let next := (N.succ next)%N in 74 | (next, turn next bd)) 75 | (0%N, {| 76 | players := (N.iter n_players (cons 0%N) [], []); 77 | marbles := ([0%N],[]) 78 | |})). 79 | 80 | (* Compute play 9 25. *) 81 | 82 | Definition maximum (xs : Zipper) : N := 83 | let '(l, r) := xs in 84 | fold_left N.max (l ++ r) 0%N. 85 | 86 | Section main. 87 | Import MonadNotation. 88 | Local Open Scope monad. 89 | 90 | Context {m : Type -> Type} `{Monad m} `{MonadError m} 91 | `{MonadI N m} `{MonadO N m}. 92 | 93 | Definition main : m unit := 94 | n_players <- read;; 95 | n_marbles <- read;; 96 | match n_players, n_marbles with 97 | | Some n_players, Some n_marbles => 98 | let bd := play n_players n_marbles in 99 | print (maximum (players bd)) 100 | | _, _ => error "Invalid input" 101 | end. 102 | 103 | End main. 104 | 105 | Import SimpleIO. 106 | Definition exe : io_unit := IO.unsafe_run main. 107 | Extraction "day09_1.ml" exe. 108 | -------------------------------------------------------------------------------- /lib/utils.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List. 3 | Import ListNotations. 4 | 5 | From ExtLib Require Import 6 | Structures.Monad. 7 | 8 | Fixpoint find_some {A B : Type} 9 | (f : A -> option B) (xs : list A) : option B := 10 | match xs with 11 | | [] => None 12 | | x :: xs => 13 | match f x with 14 | | None => find_some f xs 15 | | Some y => Some y 16 | end 17 | end. 18 | 19 | Fixpoint eqb_list {A : Type} (eqb : A -> A -> bool) 20 | (xs xs' : list A) : bool := 21 | match xs, xs' with 22 | | [], [] => true 23 | | x :: xs, x' :: xs' => 24 | eqb x x' && eqb_list eqb xs xs' 25 | | _, _ => false 26 | end. 27 | 28 | (* Properties *) 29 | 30 | Lemma find_some_ex {A B : Type} 31 | (f : A -> option B) (xs : list A) (y : B) : 32 | find_some f xs = Some y -> exists x, In x xs /\ f x = Some y. 33 | Proof. 34 | induction xs as [| x xs IH]; intros Hy. 35 | - inversion Hy. 36 | - simpl in Hy. 37 | destruct (f x) eqn:Hx. 38 | + exists x; inversion Hy; subst; firstorder. 39 | + destruct IH as [x' H']; auto. 40 | exists x'; firstorder. 41 | Qed. 42 | 43 | Lemma eqb_list_eq {A : Type} 44 | (eqb : A -> A -> bool) 45 | (eqb_eq : forall x y, eqb x y = true -> x = y) : 46 | forall xs ys, eqb_list eqb xs ys = true -> xs = ys. 47 | Proof. 48 | induction xs as [|x xs IH]; intros [|y ys]; try discriminate. 49 | - reflexivity. 50 | - simpl; intros Hs. 51 | apply andb_prop in Hs. 52 | destruct Hs as [Hx Hxs]. 53 | rewrite (eqb_eq x y) by apply Hx. 54 | rewrite (IH ys) by apply Hxs. 55 | reflexivity. 56 | Qed. 57 | 58 | Lemma iter_cons {A : Type} (a : A) (n : nat) (xs : list A) : 59 | PeanoNat.Nat.iter n (cons a) xs = repeat a n ++ xs. 60 | Proof. 61 | induction n; simpl; auto. 62 | rewrite IHn; auto. 63 | Qed. 64 | 65 | Lemma repeat_nth1 {A : Type} (m n : nat) (a b : A) : 66 | m < n -> nth m (repeat a n) b = a. 67 | Proof. 68 | generalize dependent n. 69 | induction m; intros; destruct n; auto; try solve [inversion H]. 70 | apply IHm, Lt.lt_S_n; auto. 71 | Qed. 72 | 73 | Lemma repeat_nth2 {A : Type} (m n : nat) (a b : A) : 74 | n <= m -> nth m (repeat a n) b = b. 75 | Proof. 76 | generalize dependent n. 77 | induction m; intros; destruct n; auto; try solve [inversion H]. 78 | apply IHm, le_S_n; auto. 79 | Qed. 80 | 81 | Lemma nth_nil {A : Type} (n : nat) (a : A) : 82 | nth n [] a = a. 83 | Proof. 84 | destruct n; auto. 85 | Qed. 86 | 87 | Lemma fold_left_hom {A B C} 88 | (f : A -> B -> A) (g : C -> B -> C) (h : A -> C) xs y : 89 | (forall a b, h (f a b) = g (h a) b) -> 90 | h (fold_left f xs y) = fold_left (fun a b => g a b) xs (h y). 91 | Proof. 92 | intros. 93 | generalize dependent y. 94 | induction xs; auto; intros; simpl. 95 | rewrite IHxs, H; auto. 96 | Qed. 97 | 98 | Lemma fold_left_map {A B C} (f : A -> B -> A) (g : C -> B) xs y : 99 | fold_left (fun y x => f y (g x)) xs y = fold_left f (map g xs) y. 100 | Proof. 101 | revert y. 102 | induction xs; auto; intros; simpl. 103 | rewrite IHxs; auto. 104 | Qed. 105 | 106 | Lemma fold_left_cons_1 {A : Type} (xs ys : list A) : 107 | fold_left (fun xs x => x :: xs) xs ys = rev xs ++ ys. 108 | Proof. 109 | revert ys; induction xs; intros; simpl; auto. 110 | rewrite <- app_assoc; auto. 111 | Qed. 112 | 113 | Lemma fold_left_cons {A : Type} (xs : list A) : 114 | fold_left (fun xs x => x :: xs) xs [] = rev xs. 115 | Proof. 116 | rewrite fold_left_cons_1. rewrite app_nil_r. reflexivity. 117 | Qed. 118 | 119 | (* Monadic stuff *) 120 | 121 | (* TODO: send to ext-lib *) 122 | Fixpoint for' {m : Type -> Type} `{Monad m} {A : Type} 123 | (xs : list A) (f : A -> m unit) : m unit := 124 | match xs with 125 | | [] => ret tt 126 | | x :: xs => bind (f x) (fun _ => for' xs f) 127 | end. 128 | 129 | (**) 130 | 131 | (* A default value for inhabited types. Instances are expected to 132 | be made opaque, so that proofs cannot rely on these values. 133 | [[ 134 | Instance Dummy_MyType : Dummy MyType. 135 | Proof. exact (myValue : MyType). Qed. 136 | ]] 137 | *) 138 | Class Dummy (A : Type) : Type := dummy : A. 139 | -------------------------------------------------------------------------------- /sol/day03_2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List Arith NArith ZArith Ascii String 3 | Orders Sorting 4 | OrderedTypeEx FSetAVL FMapAVL 5 | extraction.ExtrOcamlIntConv 6 | Lia. 7 | Import ListNotations. 8 | 9 | From SimpleIO Require SimpleIO. 10 | 11 | From ExtLib Require Import 12 | Structures.Monads. 13 | Import MonadNotation. 14 | Local Open Scope monad. 15 | 16 | From advent Require Import lib. 17 | 18 | (* Sets indexed by natural numbers. *) 19 | Module NSet := FSetAVL.Make N_as_OT. 20 | 21 | Variant rectangle : Type := 22 | | Rectangle (id : N) (left top width height : N) 23 | . 24 | 25 | (* We sort rectangles by the position of their top side 26 | (remember that the Y axis points downwards). *) 27 | Module RectangleOrder <: TotalLeBool. 28 | Definition t : Type := rectangle. 29 | Definition leb (r1 r2 : rectangle) := 30 | let '(Rectangle _ _ t1 _ _) := r1 in 31 | let '(Rectangle _ _ t2 _ _) := r2 in 32 | (t1 <=? t2)%N. 33 | Theorem leb_total : forall r1 r2, 34 | leb r1 r2 = true \/ leb r2 r1 = true. 35 | Proof. 36 | intros [] []; simpl. 37 | destruct N.leb eqn:e; auto. 38 | right. apply N.leb_le, N.lt_le_incl, N.leb_gt. auto. 39 | Qed. 40 | End RectangleOrder. 41 | 42 | Module Import RectangleSort := Sort RectangleOrder. 43 | 44 | Definition close_overlap (r1 r2 : rectangle) : bool := 45 | let '(Rectangle _ l1 _ w1 _) := r1 in 46 | let '(Rectangle _ l2 _ w2 _) := r2 in 47 | ((l1 <=? l2)%N && (l2 bool) (xs : list A) : list A := 51 | match xs with 52 | | [] => [] 53 | | x :: xs => 54 | if p x then x :: take_while p xs 55 | else [] 56 | end. 57 | 58 | (* Having sorted the list of rectangles, given a rectangle [r1] 59 | with top side at [t1] and with height [h1], we can first filter 60 | out rectangles whose top side is lower than [t1 + h1]. *) 61 | Definition high_enough (r1 r2 : rectangle) : bool := 62 | let '(Rectangle _ _ t1 _ h1) := r1 in 63 | let '(Rectangle _ _ t2 _ _) := r2 in 64 | (t2 None 75 | | r :: rs => 76 | (* List of rectangles overlapping with [r] *) 77 | let olapping := filter (close_overlap r) 78 | (take_while (high_enough r) rs) in 79 | match olapping with 80 | | [] => 81 | let i := id r in 82 | if NSet.mem i overlaps then 83 | search_aux overlaps rs 84 | else 85 | Some i 86 | | _ :: _ => 87 | search_aux 88 | (fold_left (fun s x => NSet.add (id x) s) olapping overlaps) 89 | rs 90 | end 91 | end. 92 | 93 | Definition search : list rectangle -> option N := 94 | search_aux NSet.empty. 95 | 96 | Section main. 97 | 98 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} 99 | `{MonadError m} 100 | `{MonadI rectangle m} `{MonadO N m}. 101 | 102 | Definition main : m unit := 103 | rs <- read_all;; 104 | match search (sort rs) with 105 | | None => error "Rectangle not found" 106 | | Some r => print r 107 | end. 108 | 109 | End main. 110 | 111 | Module io. 112 | 113 | Import SimpleIO. 114 | Import IO.Notations. 115 | 116 | Parameter parse_rectangle : ocaml_string -> int * int * int * int * int. 117 | Extract Constant parse_rectangle => 118 | "fun s -> Scanf.sscanf s ""#%d @ %d,%d: %dx%d"" 119 | (fun i l t w h -> (((i, l), t), w), h)". 120 | 121 | Instance MonadI_rectangle_IO : MonadI rectangle IO := { 122 | read := catch_eof ( 123 | s <- read_line';; 124 | let '(i, l, t, w, h) := parse_rectangle s in 125 | ret (Rectangle (n_of_int i) (n_of_int l) (n_of_int t) (n_of_int w) (n_of_int h))) 126 | }. 127 | 128 | End io. 129 | 130 | Import SimpleIO. 131 | 132 | Definition exec : io_unit := IO.unsafe_run main. 133 | Extraction "day03_2.ml" exec. 134 | -------------------------------------------------------------------------------- /lib/io.v: -------------------------------------------------------------------------------- 1 | (* Interface for IO. *) 2 | 3 | From Coq Require Import 4 | List ZArith Ascii String 5 | extraction.ExtrOcamlIntConv. 6 | Import ListNotations. 7 | 8 | From Coq.extraction Require Import 9 | ExtrOcamlIntConv. 10 | 11 | From ExtLib Require Import 12 | Data.Monads.OptionMonad 13 | Structures.Monads. 14 | 15 | From SimpleIO Require Import SimpleIO IO_UnsafeNat. 16 | 17 | From advent.lib Require Import 18 | string. 19 | 20 | Class MonadDebug (m : Type -> Type) : Type := 21 | debug : IO unit -> m unit. 22 | 23 | Arguments debug {m _}. 24 | 25 | (* Keep this out of the instance database by default. 26 | It can be added using [Existing Instance MonadDebug_ignore]. *) 27 | Definition MonadDebug_ignore m `{Monad m} : MonadDebug m := 28 | fun _ => ret tt. 29 | 30 | Class MonadError (m : Type -> Type) : Type := 31 | error : forall a, string -> m a. 32 | 33 | Arguments error {m _ a}. 34 | 35 | (* Read inputs of type [I]. *) 36 | Class MonadI (I : Type) (m : Type -> Type) : Type := 37 | read : m (option I). 38 | 39 | (* Print outputs of type [O]. *) 40 | Class MonadO (O : Type) (m : Type -> Type) : Type := 41 | print : O -> m unit. 42 | 43 | (* Extra combinators *) 44 | 45 | (* [fold_read] can be implemented using [mfix] (and we do so below), 46 | but there are some monads for which [fold_read] can be defined 47 | [mfix] cannot. Hence we make a type class to keep this general. 48 | *) 49 | Class FoldRead (I : Type) (m : Type -> Type) : Type := 50 | fold_read : forall (S : Type), (S -> I -> S) -> S -> m S. 51 | 52 | Arguments fold_read {I m FoldRead S}. 53 | 54 | Section Combini. 55 | Import MonadNotation. 56 | Open Scope monad. 57 | 58 | Context {I : Type} {m : Type -> Type} `{Monad m}. 59 | 60 | Section DefFoldRead. 61 | Context `{MonadFix m} `{MonadI I m}. 62 | 63 | (* Consume all input with a fold. *) 64 | Global Instance FoldRead_MonadFix : FoldRead I m := 65 | fun {S : Type} (f : S -> I -> S) (s0 : S) => 66 | mfix (fun loop s => 67 | ox <- read;; 68 | match ox with 69 | | None => Monad.ret s 70 | | Some x => loop (f s x) 71 | end) s0. 72 | 73 | End DefFoldRead. 74 | 75 | Section DefReadAll. 76 | Context `{FoldRead I m}. 77 | 78 | Definition read_all : m (list I) := 79 | ys <- fold_read (fun xs x => x :: xs) [];; 80 | ret (rev' ys). 81 | 82 | End DefReadAll. 83 | 84 | End Combini. 85 | 86 | (* Implementation *) 87 | 88 | Module IO. 89 | 90 | Import IO.Notations. 91 | 92 | Definition error (a : Type) (s : string) : IO a := 93 | prerr_endline s;; exit_nat 1. 94 | 95 | Definition read_of_int {A : Type} (of_int : int -> A) 96 | : IO (option A) := 97 | catch_eof (IO.map of_int read_int). 98 | 99 | Definition print_to_int {A : Type} (to_int : A -> int) 100 | (n : A) : IO unit := 101 | print_int (to_int n);; 102 | print_newline. 103 | 104 | Instance MonadError_IO : MonadError IO := { 105 | error := IO.error; 106 | }. 107 | 108 | Instance MonadDebug_IO : MonadDebug IO := 109 | fun x => x. 110 | 111 | Instance MonadI_string_IO : MonadI string IO := { 112 | read := catch_eof read_line'; 113 | }. 114 | 115 | Instance MonadI_list_ascii_IO : MonadI (list ascii) IO := { 116 | read := IO.map (option_map list_of_string) read 117 | }. 118 | 119 | Instance MonadI_ocaml_string_IO : MonadI ocaml_string IO := { 120 | read := catch_eof read_line; 121 | }. 122 | 123 | Instance MonadI_N_IO : MonadI N IO := { 124 | read := read_of_int n_of_int; 125 | }. 126 | 127 | Instance MonadI_Z_IO : MonadI Z IO := { 128 | read := read_of_int z_of_int; 129 | }. 130 | 131 | Instance MonadI_nat_IO : MonadI nat IO := { 132 | read := read_of_int nat_of_int; 133 | }. 134 | 135 | Instance MonadO_N_IO : MonadO N IO := { 136 | print := print_to_int int_of_n; 137 | }. 138 | 139 | Instance MonadO_nat_IO : MonadO nat IO := { 140 | print := print_to_int int_of_nat; 141 | }. 142 | 143 | Instance MonadO_Z_IO : MonadO Z IO := { 144 | print := print_to_int int_of_z; 145 | }. 146 | 147 | Instance MonadO_string_IO : MonadO string IO := { 148 | print := print_endline; 149 | }. 150 | 151 | Instance MonadO_list_ascii_IO : MonadO (list ascii) IO := { 152 | print := fun s => print_endline (string_of_list s); 153 | }. 154 | 155 | Instance MonadO_ocaml_string_IO : MonadO ocaml_string IO := { 156 | print := print_endline; 157 | }. 158 | 159 | End IO. 160 | -------------------------------------------------------------------------------- /sol/day07_1.v: -------------------------------------------------------------------------------- 1 | 2 | Set Warnings "-extraction-opaque-accessed". 3 | 4 | From Coq Require Import 5 | List Arith NArith ZArith Ascii String 6 | OrderedTypeEx FSetAVL FMapAVL 7 | extraction.ExtrOcamlIntConv 8 | Lia. 9 | Import ListNotations. 10 | 11 | From SimpleIO Require SimpleIO. 12 | 13 | From ExtLib Require Import 14 | Structures.Monads. 15 | Import MonadNotation. 16 | Local Open Scope monad. 17 | 18 | From advent Require Import lib. 19 | 20 | Module NMap := FMapAVL.Make N_as_OT. 21 | Module NSet := FSetAVL.Make N_as_OT. 22 | 23 | Definition Task : Type := N. 24 | 25 | (* An edge [MkEdge i j] means task [i] must be completed before task 26 | [j]. In other words, task [j] depends on task [i]. *) 27 | Variant Edge : Type := MkEdge : Task -> Task -> Edge. 28 | 29 | Definition Edges : Type := list Edge. 30 | Definition Edges' : Type := Task -> list Task. (* Adjacency lists *) 31 | 32 | (* Map task to remaining number of tasks it depends on. *) 33 | Definition BlockingTasks : Type := NMap.t N. 34 | 35 | (* Available tasks, sorted by name. *) 36 | Definition TaskQueue : Type := NSet.t. 37 | 38 | Definition increment (task : Task) (bt : BlockingTasks) : 39 | BlockingTasks := 40 | match NMap.find task bt with 41 | | None => NMap.add task 1%N bt 42 | | Some n => let n := (n+1)%N in NMap.add task n bt 43 | end. 44 | 45 | Definition decrement_and_get (task : Task) (bt : BlockingTasks) : 46 | N * BlockingTasks := 47 | match NMap.find task bt with 48 | | None => (0%N, bt) (* Should not happen. *) 49 | | Some n => let n := (n-1)%N in (n, NMap.add task n bt) 50 | end. 51 | 52 | Fixpoint order_tasks' (edges : Edges') (n_tasks : nat) 53 | (q : TaskQueue) (bt : BlockingTasks) : list Task := 54 | match n_tasks, NSet.min_elt q with 55 | | O, _ | _, None => [] 56 | | S n_tasks, Some task => 57 | let q := NSet.remove task q in 58 | let '(q, bt) := fold_left (fun '(q, bt) t' => 59 | let '(i, bt) := decrement_and_get t' bt in 60 | if (i =? 0)%N then 61 | (NSet.add t' q, bt) 62 | else 63 | (q, bt)) (edges task) (q, bt) in 64 | task :: order_tasks' edges n_tasks q bt 65 | end. 66 | 67 | Definition collect_edges (edges : Edges) : Edges' := 68 | let edges_ := fold_left (fun edges_ '(MkEdge i j) => 69 | match NMap.find i edges_ with 70 | | None => NMap.add i [j] edges_ 71 | | Some js => NMap.add i (j :: js) edges_ 72 | end) edges (NMap.empty _) in 73 | fun i => match NMap.find i edges_ with 74 | | None => [] 75 | | Some js => js 76 | end. 77 | 78 | Definition count_blocking (edges : Edges) : BlockingTasks := 79 | fold_left (fun bt '(MkEdge _ j) => increment j bt) 80 | edges (NMap.empty _). 81 | 82 | Definition initial_tasks (edges : Edges) 83 | (bt : BlockingTasks) : NSet.t := 84 | fold_left (fun q '(MkEdge task _) => 85 | if NMap.mem task bt then q else NSet.add task q) 86 | edges NSet.empty. 87 | 88 | Definition order_tasks (edges : Edges) : list Task := 89 | let bt := count_blocking edges in 90 | order_tasks' (collect_edges edges) 91 | (List.length edges) 92 | (initial_tasks edges bt) 93 | bt. 94 | 95 | Variant Ordered : Type := MkOrdered : list Task -> Ordered. 96 | 97 | Section main. 98 | 99 | Context {m : Type -> Type} `{Monad m} 100 | `{FoldRead Edge m} `{MonadO Ordered m}. 101 | 102 | Definition main : m unit := 103 | edges <- read_all;; 104 | print (MkOrdered (order_tasks edges)). 105 | 106 | End main. 107 | 108 | Import SimpleIO. 109 | Require Import SimpleIO.IO_Unsafe. 110 | 111 | Parameter parse_line : ocaml_string -> IO (char * char). 112 | Extract Constant parse_line => 113 | "fun s k -> 114 | try 115 | Scanf.sscanf s 116 | ""Step %c must be finished before step %c can begin."" 117 | (fun i j -> k (i, j)) 118 | with End_of_file -> 119 | failwith (Printf.sprintf ""Parse error: %S"" s)". 120 | 121 | Definition noc (c : char) : N := 122 | n_of_int (int_of_char c). 123 | Definition con (n : N) : char := 124 | unsafe_char_of_int (int_of_n n). 125 | 126 | Instance MonadI_Edge_IO : MonadI Edge IO := { 127 | read := catch_eof ( 128 | s <- read_line;; 129 | '(i, j) <- parse_line s;; 130 | (ret (MkEdge (noc i) (noc j)))); 131 | }. 132 | 133 | Instance MonadO_Ordered_IO : MonadO Ordered IO := { 134 | print := fun '(MkOrdered os) => 135 | print (OString.of_list (List.map con os)); 136 | }. 137 | 138 | Definition exe : io_unit := IO.unsafe_run main. 139 | 140 | Extraction "day07_1.ml" exe. 141 | -------------------------------------------------------------------------------- /sol/day16_common.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | String List Arith ZArith 3 | FMapAVL OrderedTypeEx. 4 | Import ListNotations. 5 | 6 | From ExtLib.Structures Require Import 7 | Monad MonadFix. 8 | 9 | From SimpleIO Require SimpleIO. 10 | 11 | From advent Require Import lib. 12 | 13 | Local Open Scope bool_scope. 14 | 15 | (* Register or Immediate *) 16 | Variant RI : Type := R | I. 17 | 18 | Variant op : Type := 19 | | Add (riB : RI) 20 | | Mul (riB : RI) 21 | | Ban (riB : RI) 22 | | Bor (riB : RI) 23 | | Set' (riA : RI) (* [Set] is a Coq keyword :( *) 24 | (* Never I I *) 25 | | Gt (riA riB : RI) 26 | | Eq (riA riB : RI) 27 | . 28 | 29 | Definition show_ri (ri : RI) : string := 30 | match ri with 31 | | R => "r" 32 | | I => "i" 33 | end. 34 | 35 | Definition show_op (o : op) : string := 36 | match o with 37 | | Add ri => "add" ++ show_ri ri 38 | | Mul ri => "mul" ++ show_ri ri 39 | | Ban ri => "ban" ++ show_ri ri 40 | | Bor ri => "bor" ++ show_ri ri 41 | | Set' ri => "set" ++ show_ri ri 42 | | Gt ri1 ri2 => "gt" ++ show_ri ri1 ++ show_ri ri2 43 | | Eq ri1 ri2 => "eq" ++ show_ri ri1 ++ show_ri ri2 44 | end. 45 | 46 | Definition eqb_ri (ri1 ri2 : RI) : bool := 47 | match ri1, ri2 with 48 | | R, R | I, I => true 49 | | _, _ => false 50 | end. 51 | 52 | Lemma eq_eqb_ri ri1 ri2 : 53 | ri1 = ri2 -> eqb_ri ri1 ri2 = true. 54 | Proof. 55 | destruct ri1; intros []; reflexivity. 56 | Qed. 57 | 58 | Definition eqb_op o1 o2 : bool := 59 | match o1, o2 with 60 | | Add ri1, Add ri2 | Mul ri1, Mul ri2 61 | | Ban ri1, Ban ri2 | Bor ri1, Bor ri2 62 | | Set' ri1, Set' ri2 => 63 | eqb_ri ri1 ri2 64 | | Gt riA1 riB1, Gt riA2 riB2 65 | | Eq riA1 riB1, Eq riA2 riB2 => 66 | eqb_ri riA1 riA2 && eqb_ri riB1 riB2 67 | | _, _ => false 68 | end. 69 | 70 | Lemma eq_eqb_op o1 o2 : 71 | o1 = o2 -> eqb_op o1 o2 = true. 72 | Proof. 73 | destruct o1; intros []; simpl; 74 | repeat rewrite eq_eqb_ri; reflexivity. 75 | Qed. 76 | 77 | Definition all_ops : list op := 78 | [ Add R; Add I; 79 | Mul R; Mul I; 80 | Ban R; Ban I; 81 | Bor R; Bor I; 82 | Set' R; Set' I; 83 | Gt I R; Gt R I; Gt R R; 84 | Eq I R; Eq R I; Eq R R 85 | ]. 86 | 87 | Definition instr : Type := op * Z * Z * Z. 88 | 89 | Variant regs : Type := 90 | Regs (r0 : Z) (r1 : Z) (r2 : Z) (r3 : Z) 91 | . 92 | 93 | Definition eqb_reg : regs -> regs -> bool := 94 | fun '(Regs r0 r1 r2 r3) '(Regs s0 s1 s2 s3) => 95 | ((r0 =? s0) && (r1 =? s1) && (r2 =? s2) && (r3 =? s3))%Z. 96 | 97 | Instance Dummy_RI : Dummy RI. 98 | Proof. exact R. Qed. 99 | 100 | Instance Dummy_op : Dummy op. 101 | Proof. exact (Add dummy). Qed. 102 | 103 | Instance Dummy_regs : Dummy regs. 104 | Proof. exact (Regs 0%Z 0%Z 0%Z 0%Z). Qed. 105 | 106 | Instance Dummy_Z : Dummy Z. 107 | Proof. exact 0%Z. Qed. 108 | 109 | Definition get_reg : Z -> regs -> Z := 110 | fun i '(Regs r0 r1 r2 r3) => 111 | match i with 112 | | 0%Z => r0 113 | | 1%Z => r1 114 | | 2%Z => r2 115 | | 3%Z => r3 116 | | _ => dummy 117 | end. 118 | 119 | Definition set_reg : Z -> Z -> regs -> regs := 120 | fun i r '(Regs r0 r1 r2 r3) => 121 | match i with 122 | | 0%Z => Regs r r1 r2 r3 123 | | 1%Z => Regs r0 r r2 r3 124 | | 2%Z => Regs r0 r1 r r3 125 | | 3%Z => Regs r0 r1 r2 r 126 | | _ => dummy 127 | end. 128 | 129 | Definition get_ri (i : RI * Z) : regs -> Z := 130 | match i with 131 | | (R, i) => get_reg i 132 | | (I, i) => fun _ => i 133 | end. 134 | 135 | Definition binop_ri (f : Z -> Z -> Z) 136 | (a b : RI * Z) (c : Z) (rs : regs) : regs := 137 | set_reg c (f (get_ri a rs) (get_ri b rs)) rs. 138 | 139 | Definition boolop {A} (f : A -> A -> bool) : A -> A -> Z := 140 | fun i j => if f i j then 1%Z else 0%Z. 141 | 142 | Definition is_reg (a : Z) : bool := 143 | ((0 <=? a) && (a is_reg a 148 | | I => true 149 | end. 150 | 151 | Definition wf : instr -> bool := 152 | fun '(o, a, b, _) => 153 | match o with 154 | | Add riB | Mul riB | Ban riB 155 | | Bor riB => is_ri riB b 156 | | Set' riA => is_ri riA a 157 | | Gt riA riB | Eq riA riB => is_ri riA a && is_ri riB b 158 | end. 159 | 160 | Definition interp : instr -> regs -> regs := 161 | fun '(o, a, b, c) rs => 162 | match o with 163 | | Add riB => binop_ri Z.add (R, a) (riB, b) c rs 164 | | Mul riB => binop_ri Z.mul (R, a) (riB, b) c rs 165 | | Ban riB => binop_ri Z.land (R, a) (riB, b) c rs 166 | | Bor riB => binop_ri Z.lor (R, a) (riB, b) c rs 167 | | Set' riA => set_reg c (get_ri (riA, a) rs) rs 168 | | Gt riA riB => binop_ri (boolop Z.gtb) (riA, a) (riB, b) c rs 169 | | Eq riA riB => binop_ri (boolop Z.eqb) (riA, a) (riB, b) c rs 170 | end. 171 | 172 | Module example. 173 | 174 | Example ex : 175 | interp (Add R, 2, 1, 2)%Z (Regs 3 2 1 1) = Regs 3 2 3 1. 176 | Proof. reflexivity. Qed. 177 | 178 | End example. 179 | -------------------------------------------------------------------------------- /lib/itree.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List 3 | Relations Morphisms. 4 | Import ListNotations. 5 | 6 | From ITree Require Export 7 | ITree StdEffects MorphismsFacts. 8 | 9 | From ExtLib Require Import 10 | Structures.Monad. 11 | Import MonadNotation. 12 | Local Open Scope monad_scope. 13 | 14 | From advent.lib Require Import io rel. 15 | 16 | (* We need [stateE] and [failureE] *) 17 | 18 | Definition ioE (I O : Type) : Type -> Type := stateE (io_state I O). 19 | 20 | Definition run_io {I O : Type} {E : Type -> Type} 21 | (s : io_state I O) : 22 | forall R, itree (ioE I O +' E) R -> itree E (io_state I O * R) := 23 | fun _ => run_state s. 24 | 25 | Instance MonadError_itree (E : Type -> Type) 26 | `{failureE -< E} : MonadError (itree E) := { 27 | error := fun _ s => fail s; 28 | }. 29 | 30 | Instance MonadI_itree (I O : Type) (E : Type -> Type) 31 | `{ioE I O -< E} : MonadI I (itree E) := { 32 | read := 33 | s <- get;; 34 | match input s with 35 | | [] => ret None 36 | | c :: cs => 37 | put (Mk_io_state cs (output s));; 38 | ret (Some c) 39 | end 40 | }. 41 | 42 | Instance MonadO_itree (I O : Type) (E : Type -> Type) 43 | `{ioE I O -< E} : MonadO O (itree E) := { 44 | print x := 45 | s <- get;; 46 | put (Mk_io_state (input s) (output s ++ [x])); 47 | }. 48 | 49 | Instance FoldRead_itree (I O : Type) (E : Type -> Type) 50 | `{ioE I O -< E} : FoldRead I (itree E) := { 51 | fold_read S f s0 := 52 | mfix (fun _ => S) (fun _ inc loop s => 53 | oi <- inc _ read;; 54 | match oi with 55 | | None => ret s 56 | | Some i => loop (f s i) 57 | end 58 | ) s0; 59 | }. 60 | 61 | (* We could generalize [failureE], but we may need to be careful 62 | about how instances resolve. *) 63 | (* Compared to [io_rel], we get determinism for free. *) 64 | Definition itree_spec' {I O R : Type} 65 | (t : itree (ioE I O +' failureE) R) 66 | (s s' : io_state I O) (r : R) : Prop := 67 | eutt (run_io s _ t) 68 | (Ret (s', r)). 69 | 70 | Definition itree_spec {I O : Type} 71 | (t : itree (ioE I O +' failureE) unit) 72 | (i : list I) (o : list O) := 73 | exists s', 74 | itree_spec' t (Mk_io_state i []) s' tt /\ 75 | output s' = o. 76 | 77 | Instance Proper_run_io {I O R : Type} {E : Type -> Type} s : 78 | Proper (eutt ==> eutt) 79 | (@run_io I O E s R). 80 | Proof. 81 | Admitted. 82 | 83 | Instance Proper_itree_spec' {I O R : Type} : 84 | Proper (eutt ==> eq ==> eq ==> eq ==> iff) 85 | (@itree_spec' I O R). 86 | Proof. 87 | intros t1 t2 Ht i1 i2 [] o1 o2 [] r1 r2 []. 88 | unfold itree_spec'. rewrite Ht; reflexivity. 89 | Qed. 90 | 91 | Lemma spec_bind {I O A B : Type} 92 | (a : A) 93 | (s1 s2 s3 : io_state I O) 94 | (m : itree _ A) (k : A -> itree _ B) 95 | (b : B) : 96 | itree_spec' m s1 s2 a -> 97 | itree_spec' (k a) s2 s3 b -> 98 | itree_spec' (m >>= k) s1 s3 b. 99 | Proof. 100 | unfold itree_spec', run_io, run_state. 101 | intros Hm Hk. 102 | rewrite interp_state_bind. 103 | subst. 104 | rewrite Hm. cbn. 105 | rewrite ret_bind. 106 | simpl. 107 | rewrite Hk. 108 | reflexivity. 109 | Qed. 110 | 111 | Lemma spec_fold_read {I O A : Type} 112 | (f : A -> I -> A) 113 | (s1 s2 : io_state I O) (a0 : A) : 114 | s2 = Mk_io_state [] (output s1) -> 115 | itree_spec' (fold_read f a0) s1 s2 (fold_left f (input s1) a0). 116 | Proof. 117 | pose proof @spec_bind as spec_bind. simpl in spec_bind. 118 | remember (input s1) as i1. 119 | revert a0 s2. generalize dependent s1. 120 | induction i1; intros. 121 | - unfold fold_read, FoldRead_itree. 122 | rewrite mfix_unfold. 123 | eapply spec_bind. 124 | + eapply spec_bind. 125 | * unfold itree_spec', run_io, run_state. 126 | unfold get, lift, embed, Embeddable_itree, lift. 127 | rewrite interp_state_liftE. 128 | simpl. reflexivity. 129 | * rewrite <- Heqi1. 130 | unfold itree_spec', run_io, run_state. simpl. 131 | rewrite interp_state_ret. reflexivity. 132 | + simpl. 133 | unfold itree_spec', run_io, run_state. 134 | rewrite interp_state_ret. 135 | destruct s1. 136 | simpl in Heqi1. subst. reflexivity. 137 | - unfold fold_read, FoldRead_itree. 138 | rewrite mfix_unfold. 139 | eapply spec_bind. simpl. unfold id. 140 | eapply spec_bind. 141 | unfold itree_spec', run_io, run_state. 142 | unfold get, lift, embed, Embeddable_itree, lift. 143 | rewrite interp_state_liftE. 144 | simpl. reflexivity. 145 | rewrite <- Heqi1. 146 | eapply spec_bind. 147 | unfold itree_spec', run_io, run_state. 148 | unfold put, lift. 149 | repeat (unfold embed, Embeddable_forall, Embeddable_itree, lift). 150 | rewrite interp_state_liftE. 151 | simpl. reflexivity. 152 | unfold itree_spec', run_io, run_state; simpl. 153 | rewrite interp_state_ret. 154 | reflexivity. 155 | simpl. 156 | apply IHi1; auto. 157 | Qed. 158 | -------------------------------------------------------------------------------- /lib/string.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | Ascii String List OrderedType. 3 | Import ListNotations. 4 | 5 | (* Convert between strings and lists. *) 6 | 7 | Fixpoint list_of_string (s : string) : list ascii := 8 | match s with 9 | | ""%string => [] 10 | | String c s => c :: list_of_string s 11 | end. 12 | 13 | Fixpoint string_of_list (cs : list ascii) : string := 14 | match cs with 15 | | [] => ""%string 16 | | c :: cs => String c (string_of_list cs) 17 | end. 18 | 19 | (* [ascii] as an [OrderedType]. *) 20 | 21 | Class Ordered (T : Type) : Type := { 22 | lt : T -> T -> Prop; 23 | }. 24 | 25 | Class OrderedGood (T : Type) `{Ordered T} : Type := { 26 | lt_trans : forall t1 t2 t3, lt t1 t2 -> lt t2 t3 -> lt t1 t3; 27 | lt_not_eq : forall t1 t2, lt t1 t2 -> t1 <> t2; 28 | }. 29 | 30 | Class Comparable (T : Type) `{Ordered T} : Type := { 31 | compare : forall t1 t2, OrderedType.Compare lt eq t1 t2; 32 | }. 33 | 34 | Instance Ordered_bool : Ordered bool := { 35 | lt b1 b2 := b1 = false /\ b2 = true; 36 | }. 37 | 38 | Instance OrderedGood_bool : OrderedGood bool := {}. 39 | Proof. 40 | - firstorder. 41 | - firstorder; subst; auto. 42 | Qed. 43 | 44 | Instance Comparable_bool : Comparable bool := { 45 | compare b1 b2 := 46 | match b1, b2 return OrderedType.Compare _ _ b1 b2 with 47 | | true, true => EQ eq_refl 48 | | true, false => GT (conj eq_refl eq_refl) 49 | | false, true => LT (conj eq_refl eq_refl) 50 | | false, false => EQ eq_refl 51 | end 52 | }. 53 | 54 | Instance Ordered_pair (T1 T2 : Type) 55 | `{H1 : Ordered T1} `{H2 : Ordered T2} : Ordered (T1 * T2) := { 56 | lt p1 p2 := lt (fst p1) (fst p2) \/ 57 | (fst p1 = fst p2 /\ lt (snd p1) (snd p2)); 58 | }. 59 | 60 | Instance OrderedGood_pair (T1 T2 : Type) 61 | `{H1 : OrderedGood T1} `{H2 : OrderedGood T2} : 62 | OrderedGood (T1 * T2). 63 | Proof. 64 | destruct H1 as [lt_trans1 lt_not_eq1], H2 as [lt_trans2 lt_not_eq2]. 65 | constructor. 66 | { intros t1 t2 t3 [H12 | [H12 H12']] [H23 | [H23 H23']]. 67 | - left; eapply lt_trans1; eauto. 68 | - left; rewrite <- H23; auto. 69 | - left; rewrite H12; auto. 70 | - right; split. 71 | + etransitivity; eauto. 72 | + eapply lt_trans2; eauto. 73 | } 74 | { intros t1 t2 [H12 | [H12 H12']] t_eq; subst. 75 | - eapply lt_not_eq1; eauto. 76 | - eapply lt_not_eq2; eauto. 77 | } 78 | Qed. 79 | 80 | Instance Comparable_pair (T1 T2 : Type) 81 | `{Comparable T1} `{Comparable T2} : Comparable (T1 * T2) := { 82 | compare t1 t2 := 83 | match compare (fst t1) (fst t2) with 84 | | EQ Heq1 => 85 | match compare (snd t1) (snd t2) with 86 | | EQ Heq2 => _ 87 | | GT Hgt2 => _ 88 | | LT Hlt2 => _ 89 | end 90 | | GT Hgt1 => _ 91 | | LT Hlt1 => _ 92 | end; 93 | }. 94 | Proof. 95 | - firstorder. 96 | - firstorder. 97 | - apply EQ; destruct t1, t2; f_equal; auto. 98 | - apply GT; firstorder. 99 | - apply GT; firstorder. 100 | Defined. 101 | 102 | Definition tuple_of_ascii := 103 | fun '(Ascii a b c d e f g h) => (a, b, c, d, e, f, g, h). 104 | 105 | Lemma tuple_of_ascii_inj : forall t1 t2, 106 | tuple_of_ascii t1 = tuple_of_ascii t2 -> 107 | t1 = t2. 108 | Proof. 109 | intros [] [] H; inversion H; auto. 110 | Qed. 111 | 112 | Module Ascii_OT <: OrderedType.OrderedType. 113 | Definition t : Type := ascii. 114 | Definition eq : t -> t -> Prop := eq. 115 | 116 | Definition lt : t -> t -> Prop := 117 | fun t1 t2 => lt (tuple_of_ascii t1) (tuple_of_ascii t2). 118 | 119 | Definition eq_refl : forall x : t, eq x x := @eq_refl _. 120 | Definition eq_sym : forall x y : t, eq x y -> eq y x := @eq_sym _. 121 | Definition eq_trans : forall x y z : t, eq x y -> eq y z -> eq x z := @eq_trans _. 122 | 123 | Lemma lt_trans : forall x y z : t, lt x y -> lt y z -> lt x z. 124 | Proof. 125 | intros [] [] []. 126 | apply lt_trans. 127 | Qed. 128 | 129 | Lemma lt_not_eq : forall x y : t, lt x y -> ~ eq x y. 130 | Proof. 131 | intros [] [] lt_t eq_ascii. 132 | apply lt_not_eq in lt_t. 133 | apply lt_t. 134 | inversion eq_ascii; auto. 135 | Qed. 136 | 137 | Lemma compare : forall x y : t, OrderedType.Compare lt eq x y. 138 | Proof. 139 | intros t1 t2. 140 | destruct (compare (tuple_of_ascii t1) (tuple_of_ascii t2)). 141 | - apply LT. auto. 142 | - apply EQ. apply tuple_of_ascii_inj; auto. 143 | - apply GT. auto. 144 | Defined. 145 | 146 | Definition eq_dec : forall x y : t, {eq x y} + {~ eq x y}. 147 | Proof. 148 | intros t1 t2. 149 | destruct (compare t1 t2). 150 | - right. apply lt_not_eq; auto. 151 | - left; auto. 152 | - right. intro H; symmetry in H; apply lt_not_eq in H; auto. 153 | Defined. 154 | End Ascii_OT. 155 | 156 | Definition eqb_ascii (a b : ascii) : bool := 157 | if Ascii_OT.eq_dec a b then true else false. 158 | 159 | Lemma eqb_eq (a b : ascii) : eqb_ascii a b = true <-> a = b. 160 | Proof. 161 | unfold eqb_ascii. 162 | destruct Ascii_OT.eq_dec; split; auto. discriminate. 163 | Qed. 164 | 165 | Lemma neqb_neq (a b : ascii) : eqb_ascii a b = false <-> a <> b. 166 | Proof. 167 | rewrite <- eqb_eq, Bool.not_true_iff_false; reflexivity. 168 | Qed. 169 | -------------------------------------------------------------------------------- /lib/mock_spec.v: -------------------------------------------------------------------------------- 1 | (* Failed attempts at defining specifications on mocked programs. 2 | Damn [mfix]. 3 | *) 4 | 5 | From Coq Require Import 6 | List ZArith 7 | extraction.ExtrOcamlIntConv. 8 | Import ListNotations. 9 | 10 | From Coq.extraction Require Import 11 | ExtrOcamlIntConv. 12 | 13 | From ExtLib Require Import 14 | Data.Monads.OptionMonad 15 | Structures.Monads. 16 | 17 | From advent.lib Require Import 18 | io mock. 19 | 20 | (* partial correctness *) 21 | Module fuel_partial. 22 | 23 | Definition spec' {a : Type} 24 | (m : fuelT (mock Prop) a) 25 | (i : input) 26 | (post : input -> Prop) (o : output) (x : a) : Prop := 27 | forall fuel, 28 | un_mock (m fuel) (fun ox' i' o' => 29 | forall x', ox' = Some x' -> 30 | x' = x /\ 31 | post i' /\ 32 | o' = o) i. 33 | 34 | Lemma spec_fix {a b} gf i (post : input -> Prop) o (x : a) (y : b) : 35 | spec' (gf (mfix gf) x) i post o y -> 36 | spec' (mfix gf x) i post o y. 37 | Proof. 38 | intros Hspec fuel. 39 | Abort. 40 | 41 | End fuel_partial. 42 | 43 | Module fuel. 44 | 45 | Definition spec' {a : Type} 46 | (m : fuelT (mock Prop) a) 47 | (i : input) 48 | (post : input -> Prop) (o : output) (x : a) : Prop := 49 | exists min_fuel, 50 | forall (P : _ -> _ -> _ -> Prop) fuel, 51 | fuel >= min_fuel -> 52 | (forall x' i' o', 53 | x' = Some x /\ post i' /\ o' = o -> P x' i' o') -> 54 | un_mock (m fuel) P i. 55 | 56 | Definition spec (m : fuelT (mock Prop) unit) (i : input) (o : output) : Prop := 57 | exists min_fuel, 58 | forall fuel, 59 | fuel >= min_fuel -> 60 | un_mock (m fuel) (fun x' i' o' => 61 | x' = Some tt /\ o' = o) i. 62 | 63 | Lemma unfold_spec m i o : 64 | spec' m i (fun _ => True) o tt -> 65 | spec m i o. 66 | Proof. 67 | intros [min_fuel Hspec']. 68 | exists min_fuel. 69 | intros fuel Hfuel. 70 | apply Hspec'; auto. 71 | firstorder. 72 | Qed. 73 | 74 | Lemma strong_post {a} m i (post1 post2 : input -> Prop) o (x : a) : 75 | (forall i', post1 i' -> post2 i') -> 76 | spec' m i post1 o x -> 77 | spec' m i post2 o x. 78 | Proof. 79 | intros Hpost [min_fuel Hspec']. 80 | exists min_fuel. intros P fuel Hfuel HP. 81 | apply Hspec'; auto. 82 | firstorder. 83 | Qed. 84 | 85 | Lemma spec_fix {a b} gf i (post : input -> Prop) o (x : a) (y : b) : 86 | spec' (gf (mfix gf) x) i post o y -> 87 | spec' (mfix gf x) i post o y. 88 | Proof. 89 | intros [min_fuel Hspec]. 90 | exists (S min_fuel); intros P fuel Hfuel HP. 91 | induction fuel. 92 | - inversion Hfuel. 93 | - simpl. 94 | Abort. 95 | 96 | End fuel. 97 | 98 | (* Interpret the CPS-style [mock] as a predicate transformer. *) 99 | Module wp. 100 | 101 | Notation wp := (mock Prop). 102 | 103 | Definition incl_wp {a : Type} (m1 m2 : wp a) : Prop := 104 | forall q i, un_mock m1 q i -> un_mock m2 q i. 105 | 106 | Notation GF_wp a b := ((a -> wp b) -> (a -> wp b)). 107 | 108 | (* 109 | Definition mfix_wp {a b : Type} 110 | (gf : GF_wp a b) 111 | (x : a) 112 | (q : b -> input -> output -> Prop) 113 | (i : input) : Prop := 114 | forall 115 | (P : a -> mock Prop b) 116 | (P_ind : forall y, incl_wp (P y) (gf P y)), 117 | un_mock (P x) q i. 118 | *) 119 | 120 | Variant mfix_wp {a b : Type} 121 | (gf : GF_wp a b) 122 | (x : a) 123 | (q : b -> input -> output -> Prop) 124 | (i : input) : Prop := 125 | | MWP 126 | (P : a -> mock Prop b) 127 | (PHolds : un_mock (P x) q i) 128 | (P_ind :forall y, incl_wp (P y) (gf P y)) 129 | . 130 | 131 | Global Instance MonadFix_mock_Prop : MonadFix wp := { 132 | mfix _ _ gf x := Mk_mock (mfix_wp gf x) 133 | }. 134 | 135 | Definition monotonic_wp {a b : Type} 136 | (gf : GF_wp a b) := 137 | forall m1 m2, 138 | (forall x, incl_wp (m1 x) (m2 x)) -> 139 | (forall x, incl_wp (gf m1 x) (gf m2 x)). 140 | 141 | Theorem mfix_incl_1 {a b : Type} 142 | (gf : GF_wp a b) 143 | (gf_mon : monotonic_wp gf) 144 | (x : a) : 145 | incl_wp (mfix gf x) (gf (mfix gf) x). 146 | Proof. 147 | intros q i [P PHolds P_ind]; simpl. 148 | eapply gf_mon. 149 | - unfold incl_wp; simpl. 150 | intros. 151 | econstructor. 152 | + eauto. 153 | + apply P_ind. 154 | - apply P_ind; auto. 155 | Qed. 156 | 157 | (* 158 | Theorem mfix_incl_1 {a b : Type} 159 | (gf : GF_mp a b) 160 | (gf_mon : monotonic_mp gf) 161 | (x : a) : 162 | incl_mp (mfix gf x) (gf (mfix gf) x). 163 | Proof. 164 | intros q i [P PHolds P_ind]; simpl. 165 | eapply gf_mon. 166 | - unfold incl_mp; simpl. 167 | intros. 168 | econstructor. 169 | + eauto. 170 | + apply P_ind. 171 | - apply P_ind; auto. 172 | Qed. 173 | *) 174 | 175 | Theorem mfix_incl_2 {a b : Type} 176 | (gf : GF_wp a b) 177 | (gf_mon : monotonic_wp gf) 178 | (x : a) : 179 | incl_wp (gf (mfix gf) x) (mfix gf x). 180 | Proof. 181 | intros q i H. 182 | econstructor. 183 | - eapply H. 184 | - intros x' q' i'. intro. 185 | eapply gf_mon; eauto. 186 | Abort. 187 | 188 | End wp. 189 | -------------------------------------------------------------------------------- /sol/day16_2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | String List Arith ZArith 3 | FMapAVL OrderedTypeEx 4 | extraction.ExtrOcamlIntConv. 5 | Import ListNotations. 6 | 7 | From ExtLib.Structures Require Import 8 | Monad MonadFix. 9 | 10 | From SimpleIO Require SimpleIO. 11 | 12 | From advent Require Import lib sol.day16_common. 13 | 14 | Module ZMap := FMapAVL.Make Z_as_OT. 15 | 16 | Definition assignments : Type := ZMap.t (list op). 17 | 18 | Definition initial_assignments : assignments := 19 | snd (Z.iter 16 20 | (fun '(i, t) => ((i + 1)%Z, ZMap.add i all_ops t)) 21 | (0%Z, ZMap.empty _)). 22 | 23 | Definition show_list {A : Type} 24 | (show : A -> string) (xs : list A) : string := 25 | "[" ++ (fix aux xs : string := 26 | match xs with 27 | | [] => "]" 28 | | [x] => show x ++ "]" 29 | | x :: xs => show x ++ "," ++ aux xs 30 | end%string) xs. 31 | 32 | Section show. 33 | Import SimpleIO. 34 | 35 | Definition show_z (z : Z) : string := 36 | from_ostring (ostring_of_int (int_of_z z)). 37 | 38 | Definition show_assignments (p : assignments) : string := 39 | show_list 40 | (fun '(i, os) => show_z i ++ ":" ++ show_list show_op os)%string 41 | (ZMap.elements p). 42 | 43 | Definition show_code : list (Z * op) -> string := 44 | show_list (fun '(i, o) => 45 | show_z i ++ ":" ++ show_op o)%string. 46 | 47 | End show. 48 | 49 | Section enum. 50 | Import SimpleIO. 51 | 52 | Inductive stream' (A : Type) := 53 | | snil 54 | | scons : A -> (unit -> stream' A) -> stream' A 55 | . 56 | 57 | Definition stream (A : Type) := unit -> stream' A. 58 | 59 | Fixpoint enum_aux (os : list (Z * op)) (p : list (Z * list op)) : 60 | stream (list (Z * op)) -> stream (list (Z * op)) := 61 | fun s (_ : unit) => 62 | match p with 63 | | [] => scons _ (rev' os) s 64 | | (i, os') :: p => 65 | fold_left 66 | (fun s o => 67 | if existsb (fun '(_, o') => eqb_op o o') os then 68 | s 69 | else 70 | enum_aux ((i, o) :: os) p s) 71 | os' s tt 72 | end. 73 | 74 | Definition enum p := enum_aux [] (ZMap.elements p) (fun _ => snil _). 75 | 76 | Definition opcode_to_op (p : list (Z * op)) : Z -> op := 77 | let m := fold_left 78 | (fun m '(i, o) => ZMap.add i o m) p (ZMap.empty _) in 79 | fun i => 80 | match ZMap.find i m with 81 | | None => dummy 82 | | Some o => o 83 | end. 84 | 85 | Variant instr : Type := 86 | Instr (opcode : Z) (a b c : Z). 87 | 88 | Definition interp_instr (oto : Z -> op) : regs -> instr -> regs := 89 | fun rs '(Instr o a b c) => 90 | interp (oto o, a, b, c) rs. 91 | 92 | End enum. 93 | 94 | Section main. 95 | 96 | Import MonadNotation. 97 | Local Open Scope monad_scope. 98 | 99 | Definition sample_ (regs instr : Type) : Type := 100 | regs * instr * regs. 101 | 102 | Definition sample : Type := sample_ regs instr. 103 | 104 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} `{MonadError m} 105 | `{MonadDebug m} 106 | `{FoldRead sample m} `{FoldRead instr m} `{MonadO Z m}. 107 | 108 | Definition test_sample : assignments -> sample -> assignments := 109 | fun p '(rs, Instr oc a b c, rs') => 110 | match ZMap.find oc p with 111 | | None => p (* Should not happen. *) 112 | | Some os => 113 | let os := 114 | filter 115 | (fun o => 116 | let is := (o, a, b, c) in 117 | wf is && eqb_reg (interp is rs) rs')%bool 118 | os in 119 | ZMap.add oc os p 120 | end. 121 | 122 | Definition deduce_assignments : m assignments := 123 | fold_read test_sample initial_assignments. 124 | 125 | Import SimpleIO. 126 | 127 | Definition check_unique {A : Type} 128 | (show : A -> string) (s : stream A) : m A := 129 | match s tt with 130 | | snil _ => error "No solution" 131 | | scons _ x s => 132 | debug (print_endline (show x));; 133 | match s tt with 134 | | snil _ => ret x 135 | | scons _ x' s => 136 | debug (print_endline (show x'));; 137 | error "Solution is not unique" 138 | end 139 | end. 140 | 141 | Definition main : m unit := 142 | p <- deduce_assignments;; 143 | debug (print_endline (show_assignments p));; 144 | code <- check_unique show_code (enum p);; 145 | let oto := opcode_to_op code in 146 | ' (Regs r0 _ _ _) <- fold_read (interp_instr oto) (Regs 0 0 0 0);; 147 | print r0. 148 | 149 | End main. 150 | 151 | Import SimpleIO. 152 | 153 | Parameter parse_sample : forall {regs instr}, 154 | (int -> int -> int -> int -> regs) -> 155 | (int -> int -> int -> int -> instr) -> 156 | IO (option (sample_ regs instr)). 157 | Extract Constant parse_sample => " 158 | fun regs instr k -> 159 | k (try 160 | Scanf.scanf 161 | ""Before: [%d, %d, %d, %d] %d %d %d %d After: [%d, %d, %d, %d] "" 162 | (fun r0 r1 r2 r3 o a b c s0 s1 s2 s3 -> 163 | Some ((regs r0 r1 r2 r3, instr o a b c), regs s0 s1 s2 s3)) 164 | with Scanf.Scan_failure _ | End_of_file -> None)". 165 | 166 | Definition read_sample : IO (option sample) := 167 | let z := z_of_int in 168 | let Regs' r0 r1 r2 r3 := Regs (z r0) (z r1) (z r2) (z r3) in 169 | let Instr' o a b c := Instr (z o) (z a) (z b) (z c) in 170 | parse_sample Regs' Instr'. 171 | 172 | Local Instance MonadI_sample_IO : MonadI sample IO := 173 | read_sample. 174 | 175 | Parameter parse_instr : forall {instr}, 176 | (int -> int -> int -> int -> instr) -> 177 | IO (option instr). 178 | Extract Constant parse_instr => " 179 | fun instr k -> 180 | k (try Scanf.scanf ""%d %d %d %d "" 181 | (fun o a b c -> Some (instr o a b c)) 182 | with End_of_file -> None)". 183 | 184 | Definition read_instr : IO (option instr) := 185 | let z := z_of_int in 186 | let Instr' o a b c := Instr (z o) (z a) (z b) (z c) in 187 | parse_instr Instr'. 188 | 189 | Local Instance MonadI_instr_IO : MonadI instr IO := 190 | read_instr. 191 | 192 | Definition exe : io_unit := IO.unsafe_run main. 193 | Extraction "day16_2.ml" exe. 194 | -------------------------------------------------------------------------------- /sol/day07_2.v: -------------------------------------------------------------------------------- 1 | 2 | Set Warnings "-extraction-opaque-accessed". 3 | 4 | From Coq Require Import 5 | List Arith NArith ZArith Ascii String 6 | OrderedTypeEx FSetAVL FMapAVL 7 | extraction.ExtrOcamlIntConv 8 | Lia. 9 | Import ListNotations. 10 | 11 | From SimpleIO Require SimpleIO. 12 | 13 | From ExtLib Require Import 14 | Structures.Monads. 15 | Import MonadNotation. 16 | Local Open Scope monad. 17 | 18 | From advent Require Import lib. 19 | 20 | Module NMap := FMapAVL.Make N_as_OT. 21 | Module NSet := FSetAVL.Make N_as_OT. 22 | 23 | Definition Task : Type := N. 24 | 25 | (* An edge [MkEdge i j] means task [i] must be completed before task 26 | [j]. In other words, task [j] depends on task [i]. *) 27 | Variant Edge : Type := MkEdge : Task -> Task -> Edge. 28 | 29 | Definition Edges : Type := list Edge. 30 | Definition Edges' : Type := Task -> list Task. (* Adjacency lists *) 31 | 32 | (* Map task to remaining number of tasks it depends on. *) 33 | Definition BlockingTasks : Type := NMap.t N. 34 | 35 | (* Available tasks, sorted by name. *) 36 | Definition TaskQueue : Type := NSet.t. 37 | 38 | Definition Time : Type := N. 39 | 40 | (* A pair [(t, tasks)] means all tasks in the list [tasks] complete 41 | at time [t]. *) 42 | Definition WorkerEvents : Type := list (Time * list Task). 43 | 44 | (* Definition WorkerEvents : Type := NMap.t (list Task). *) 45 | (* Map is missing min_elt *) 46 | 47 | Fixpoint we_insert (time : Time) (task : Task) (we : WorkerEvents) : 48 | WorkerEvents := 49 | match we with 50 | | [] => [(time, [task])] 51 | | (time', tasks') as t' :: we' => 52 | match N_as_OT.compare time time' with 53 | | OrderedType.LT _ => (time, [task]) :: we 54 | | OrderedType.EQ _ => (time, task :: tasks') :: we' 55 | | OrderedType.GT _ => t' :: we_insert time task we' 56 | end 57 | end. 58 | 59 | Definition increment (task : Task) (bt : BlockingTasks) : 60 | BlockingTasks := 61 | match NMap.find task bt with 62 | | None => NMap.add task 1%N bt 63 | | Some n => let n := (n+1)%N in NMap.add task n bt 64 | end. 65 | 66 | Definition decrement_and_get (task : Task) (bt : BlockingTasks) : 67 | N * BlockingTasks := 68 | match NMap.find task bt with 69 | | None => (0%N, bt) (* Should not happen. *) 70 | | Some n => let n := (n-1)%N in (n, NMap.add task n bt) 71 | end. 72 | 73 | Class TaskDuration : Type := 74 | task_duration : Task -> Time. 75 | 76 | Module Import DB. 77 | Import SimpleIO. 78 | (* TODO send to simple-io. *) 79 | Definition debug_switch := false. (* Switch this to [true] for debug 80 | output. *) 81 | Parameter debug' : forall {A}, ocaml_string -> int -> A -> A. 82 | Extract Constant debug' => "fun s n x -> Printf.printf ""%s: %d\n"" s n; x". 83 | Definition debug : forall {A}, string -> int -> A -> A := 84 | fun _ s => if debug_switch then debug' (to_ostring s) 85 | else fun _ x => x. 86 | End DB. 87 | 88 | Section algo. 89 | 90 | Context `{TaskDuration}. 91 | 92 | Fixpoint assign_tasks (cur_time : Time) (n_idle : nat) 93 | (we : WorkerEvents) (q : TaskQueue) : 94 | (nat * WorkerEvents * TaskQueue) := 95 | match n_idle, NSet.min_elt q with 96 | | O, _ | _, None => (n_idle, we, q) 97 | | S n_idle, Some task => 98 | let q := debug "idle" (int_of_nat n_idle) (debug "assign" (int_of_n task)) (NSet.remove task q) in 99 | let we := we_insert 100 | (cur_time + task_duration task)%N task we in 101 | assign_tasks cur_time n_idle we q 102 | end. 103 | 104 | Fixpoint order_tasks' 105 | (edges : Edges') 106 | (cur_time : Time) 107 | (n_tasks : nat) 108 | (n_idle : nat) 109 | (we : WorkerEvents) 110 | (q : TaskQueue) 111 | (bt : BlockingTasks) : Time := 112 | let '(n_idle, we, q) := assign_tasks cur_time n_idle we q in 113 | match n_tasks, we with 114 | | O, _ | _, [] => cur_time 115 | | S n_tasks, (cur_time, tasks) :: we => 116 | let '(q, bt) := fold_left (fun qbt task => 117 | fold_left (fun '(q, bt) t' => 118 | let '(i, bt) := decrement_and_get t' bt in 119 | if (i =? 0)%N then 120 | debug "Free" (int_of_n t') 121 | (NSet.add t' q, bt) 122 | else 123 | (q, bt)) (edges task) qbt) tasks (q, bt) in 124 | order_tasks' edges (debug "Compl" (int_of_n cur_time) cur_time) 125 | n_tasks (List.length tasks + n_idle) 126 | we q bt 127 | end. 128 | 129 | Definition collect_edges (edges : Edges) : Edges' := 130 | let edges_ := fold_left (fun edges_ '(MkEdge i j) => 131 | match NMap.find i edges_ with 132 | | None => NMap.add i [j] edges_ 133 | | Some js => NMap.add i (j :: js) edges_ 134 | end) edges (NMap.empty _) in 135 | fun i => match NMap.find i edges_ with 136 | | None => [] 137 | | Some js => js 138 | end. 139 | 140 | Definition count_blocking (edges : Edges) : BlockingTasks := 141 | fold_left (fun bt '(MkEdge _ j) => increment j bt) 142 | edges (NMap.empty _). 143 | 144 | Definition initial_tasks (edges : Edges) 145 | (bt : BlockingTasks) : NSet.t := 146 | fold_left (fun q '(MkEdge task _) => 147 | if NMap.mem task bt then q else NSet.add task q) 148 | edges NSet.empty. 149 | 150 | Definition we_initial : WorkerEvents := []. 151 | 152 | Definition order_tasks (n_idle : nat) (edges : Edges) : Time := 153 | let bt := count_blocking edges in 154 | order_tasks' (collect_edges edges) 155 | 0%N 156 | (List.length edges) 157 | n_idle 158 | we_initial 159 | (initial_tasks edges bt) 160 | bt. 161 | 162 | End algo. 163 | 164 | Section main. 165 | 166 | (* N.B.: TaskDuration and n_idle hardcoded here. *) 167 | 168 | (* [task] is the ASCII code of its name (a single char), 169 | and we want ['A' -> 61], ['B' -> 62], etc. *) 170 | Instance TD : TaskDuration := 171 | fun (task : Task) => (task - 4)%N : Time. 172 | 173 | Context {m : Type -> Type} `{Monad m} 174 | `{FoldRead Edge m} `{MonadO N m}. 175 | 176 | Definition main : m unit := 177 | edges <- read_all;; 178 | print (order_tasks (* n_idle:= *) 5 edges). 179 | 180 | End main. 181 | 182 | Import SimpleIO. 183 | Require Import SimpleIO.IO_Unsafe. 184 | 185 | Parameter parse_line : ocaml_string -> IO (char * char). 186 | Extract Constant parse_line => 187 | "fun s k -> 188 | try 189 | Scanf.sscanf s 190 | ""Step %c must be finished before step %c can begin."" 191 | (fun i j -> k (i, j)) 192 | with End_of_file -> 193 | failwith (Printf.sprintf ""Parse error: %S"" s)". 194 | 195 | Definition noc (c : char) : N := 196 | n_of_int (int_of_char c). 197 | Definition con (n : N) : char := 198 | unsafe_char_of_int (int_of_n n). 199 | 200 | Instance MonadI_Edge_IO : MonadI Edge IO := { 201 | read := catch_eof ( 202 | s <- read_line;; 203 | '(i, j) <- parse_line s;; 204 | (ret (MkEdge (noc i) (noc j)))); 205 | }. 206 | 207 | Definition exe : io_unit := IO.unsafe_run main. 208 | 209 | Extraction "day07_2.ml" exe. 210 | 211 | (* 212 | -->A--->B-- 213 | / \ \ 214 | C -->D----->E 215 | \ / 216 | ---->F----- 217 | 218 | 0 C 219 | 63(C) A F 220 | 124(A) B D 221 | 129(F) 222 | 186(B) 223 | 188(D) E 224 | 253(E) 225 | *) 226 | -------------------------------------------------------------------------------- /sol/day04_1.v: -------------------------------------------------------------------------------- 1 | (* The input for this one is assumed to be sorted (e.g., using 2 | the [sort] command). *) 3 | 4 | Set Warnings "-extraction-opaque-accessed". 5 | 6 | From Coq Require Import 7 | List Arith NArith ZArith Ascii String 8 | OrderedTypeEx FSetAVL FMapAVL 9 | extraction.ExtrOcamlIntConv 10 | Lia. 11 | Import ListNotations. 12 | 13 | From SimpleIO Require SimpleIO. 14 | 15 | From ExtLib Require Import 16 | Structures.Monads. 17 | Import MonadNotation. 18 | Local Open Scope monad. 19 | 20 | From advent Require Import lib. 21 | 22 | (* Sets indexed by natural numbers. *) 23 | Module NMap := FMapAVL.Make N_as_OT. 24 | 25 | (* Minutes since midnight. *) 26 | Definition time : Type := N. 27 | 28 | (* We assume shifts happen around midnight. *) 29 | Variant event : Type := 30 | | Shift (guard : N) 31 | | FallsAsleep 32 | | WakesUp 33 | . 34 | 35 | (* A list of 1 in the interval [[n1; n2-1]] *) 36 | Definition interval (n1 n2 : N) : list nat := 37 | N.iter n1 (cons 0) (N.iter (n2 - n1) (cons 1) []). 38 | 39 | Fixpoint union {A : Type} 40 | (merge : A -> A -> A) (xs ys : list A) : list A := 41 | match xs, ys with 42 | | [], _ => ys 43 | | _, [] => xs 44 | | x :: xs, y :: ys => merge x y :: union merge xs ys 45 | end. 46 | 47 | Definition union1 : list nat -> list nat -> list nat := union plus. 48 | 49 | Parameter err : forall {A}, A. 50 | Extract Inlined Constant err => "assert false". 51 | 52 | Fixpoint record_sleeps_aux (r : NMap.t (list nat)) 53 | (guard0 : N) (es : list (time * event)) : NMap.t (list nat) := 54 | match es with 55 | | (_, Shift guard) :: es => record_sleeps_aux r guard es 56 | | (i, FallsAsleep) :: (j, WakesUp) :: es => 57 | let gz := match NMap.find guard0 r with 58 | | None => [] 59 | | Some gz => gz 60 | end in 61 | let r' := NMap.add guard0 (union1 (interval i j) gz) r in 62 | record_sleeps_aux r' guard0 es 63 | | [] => r 64 | | _ => err 65 | end. 66 | 67 | Definition record_sleeps 68 | (es : list (time * event)) : NMap.t (list nat) := 69 | record_sleeps_aux (NMap.empty _) 0 es. 70 | 71 | Definition sum : list nat -> nat := 72 | fun ns => fold_left plus ns 0. 73 | 74 | Definition NMap_argmax {A : Type} (f : A -> nat) 75 | (r : NMap.t A) : nat * list (N * A) := 76 | NMap.fold (fun i x best => 77 | let y := f x in 78 | if y (best, arg) 91 | | x :: xs => 92 | if x nat * list nat := 101 | arg_max_aux 0 [] 0. 102 | 103 | (* Find the laziest guards (there should be only one in the AoC 104 | input), together with the total time they slept. *) 105 | Definition laziest1 : 106 | NMap.t (list nat) -> nat * list (N * list nat) := 107 | NMap_argmax sum. 108 | 109 | Definition laziest2 : 110 | NMap.t (list nat) -> nat * list (N * (nat * list nat)) := 111 | fun r => NMap_argmax (fun '(max_slept, _) => max_slept) 112 | (NMap.map arg_max r). 113 | 114 | Definition all_laziest1 (es : list (time * event)) : 115 | nat * list (N * nat * list nat) := 116 | let r := record_sleeps es in 117 | let '(max_sleep, offenders) := laziest1 r in 118 | let most_slept_minutes := fun '(guard, slept) => 119 | let '(m, mns) := arg_max slept in 120 | (guard, m, mns) in 121 | (max_sleep, map most_slept_minutes offenders). 122 | 123 | Definition all_laziest2 (es : list (time * event)) : 124 | nat * list (N * list nat) := 125 | let r := record_sleeps es in 126 | let '(max_slept, offenders) := laziest2 r in 127 | let most_slept_minutes := fun '(guard, (_, mns)) => 128 | (guard, mns) in 129 | (max_slept, map most_slept_minutes offenders). 130 | 131 | Section main. 132 | 133 | Import SimpleIO. 134 | 135 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} 136 | `{MonadI (time * event) m} 137 | `{MonadO ocaml_string m}. 138 | 139 | Infix "+++" := ostring_app (at level 30). 140 | 141 | Definition print_all_laziest1 (a : nat * list (N * nat * list nat)) := 142 | let '(max_sleep, offenders) := a in 143 | print (to_ostring "Total slept:");; 144 | print (ostring_of_int (int_of_nat max_sleep));; 145 | let of_n n := ostring_of_int (int_of_n n) in 146 | let of_nat n := ostring_of_int (int_of_nat n) in 147 | for' offenders (fun '(guard, max_slept, mns) => 148 | print (OString.concat (to_ostring "; ") ([ 149 | of_n guard; 150 | of_nat max_slept; 151 | OString.concat (to_ostring ",") 152 | (map (fun n => OString.concat (to_ostring ":") [ 153 | of_nat n; 154 | of_n (guard * N.of_nat n)%N]) 155 | mns)] 156 | )) 157 | ). 158 | 159 | Definition print_all_laziest2 (a : nat * list (N * list nat)) := 160 | let '(max_sleep, offenders) := a in 161 | print (to_ostring "Max slept:");; 162 | print (ostring_of_int (int_of_nat max_sleep));; 163 | let of_n n := ostring_of_int (int_of_n n) in 164 | let of_nat n := ostring_of_int (int_of_nat n) in 165 | for' offenders (fun '(guard, mns) => 166 | print (OString.concat (to_ostring "; ") ([ 167 | of_n guard; 168 | OString.concat (to_ostring ",") 169 | (map (fun n => OString.concat (to_ostring ":") [ 170 | of_nat n; 171 | of_n (guard * N.of_nat n)%N]) 172 | mns)] 173 | )) 174 | ). 175 | 176 | Definition main1 : m unit := 177 | es <- read_all;; 178 | let a := all_laziest1 es in 179 | print_all_laziest1 a. 180 | 181 | Definition main2 : m unit := 182 | es <- read_all;; 183 | let a := all_laziest2 es in 184 | print_all_laziest2 a. 185 | 186 | End main. 187 | 188 | Module io. 189 | 190 | Import SimpleIO. 191 | Import IO.Notations. 192 | 193 | (* Partial function!? *) 194 | Parameter parse_event : forall {TIME EVENT : Type}, 195 | (int -> TIME) -> 196 | (int -> EVENT) -> EVENT -> EVENT -> 197 | ocaml_string -> TIME * EVENT. 198 | 199 | Extract Constant parse_event => 200 | "fun mk_time mk_shift sleep wakeup s -> 201 | try 202 | Scanf.sscanf s ""[1518-%_d-%_d %_d:%d] %[^\n]"" 203 | (fun mn e -> 204 | (mk_time mn, match e with 205 | | ""falls asleep"" -> sleep 206 | | ""wakes up"" -> wakeup 207 | | _ -> Scanf.sscanf e ""Guard #%d"" mk_shift) 208 | ) 209 | with End_of_file -> 210 | failwith (Printf.sprintf ""Parse error: %S"" s)". 211 | 212 | Instance MonadI_event_IO : MonadI (time * event) IO := { 213 | read := catch_eof ( 214 | s <- read_line';; 215 | ret (parse_event 216 | n_of_int 217 | (fun g => Shift (n_of_int g)) FallsAsleep WakesUp 218 | s)); 219 | }. 220 | 221 | End io. 222 | 223 | Import SimpleIO. 224 | 225 | Definition exec1 : io_unit := IO.unsafe_run main1. 226 | Extraction "day04_1.ml" exec1. 227 | 228 | Definition exec2 : io_unit := IO.unsafe_run main2. 229 | Extraction "day04_2.ml" exec2. 230 | -------------------------------------------------------------------------------- /sol/day01_2.v: -------------------------------------------------------------------------------- 1 | From Coq Require Import 2 | List ZArith Ascii String Streams 3 | OrderedTypeEx FSetAVL 4 | extraction.ExtrOcamlIntConv. 5 | Import ListNotations. 6 | 7 | From SimpleIO Require SimpleIO. 8 | 9 | From ExtLib Require Import 10 | Structures.Monads. 11 | Import MonadNotation. 12 | Local Open Scope monad. 13 | 14 | From advent Require Import lib. 15 | 16 | (* Sets of integers. *) 17 | Module ZSet := FSetAVL.Make Z_as_OT. 18 | 19 | (* [cycle xs]: given a list [xs], construct an infinite stream 20 | repeating [xs]. For example (abusing list notation for streams): 21 | 22 | cycle [1; 2; 3] = Some [1; 2; 3; 1; 2; 3; ...] 23 | 24 | [None] if the list [xs] is empty. 25 | *) 26 | 27 | Definition cycle_aux {A} (self : Stream A) : list A -> Stream A := 28 | cofix cycle_aux (xs : list A) : Stream A := 29 | match xs with 30 | | [] => self 31 | | x :: xs => Cons x (cycle_aux xs) 32 | end. 33 | 34 | (* This might look a bit weird, because of the guardedness 35 | condition. *) 36 | Definition cycle {A} (xs : list A) : option (Stream A) := 37 | match xs with 38 | | [] => None 39 | | x :: xs => Some (cofix res := Cons x (cycle_aux res xs)) 40 | end. 41 | 42 | Section main. 43 | 44 | Context {m : Type -> Type} 45 | `{Monad m} `{MonadError m} 46 | `{MonadI Z m} `{MonadO Z m} `{MonadFix m}. 47 | 48 | (* Get all inputs and make a cyclic stream of them. *) 49 | Definition parse_stream : m (Stream Z) := 50 | zs <- read_all;; 51 | match cycle zs with 52 | | None => error "empty input" 53 | | Some s => ret s 54 | end. 55 | 56 | (* [search s]: viewing [s] as a stream of deltas, we replay the 57 | changes, keeping all reached positions in a set. We return the 58 | first duplicate position, if any. Otherwise we keep looping, 59 | hence this computation must be done in a suitable monad 60 | (with a [MonadFix] instance). 61 | 62 | Its specification is given (and proved) below by [search_rel]. 63 | *) 64 | 65 | Definition no_seen : ZSet.t := ZSet.empty. 66 | 67 | Definition search (s : Stream Z) : m Z := 68 | mfix (fun loop '(seen, pos, (Cons z s)) => 69 | if ZSet.mem pos seen then 70 | ret pos 71 | else 72 | loop (ZSet.add pos seen, (pos + z)%Z, s) 73 | ) (no_seen, 0%Z, s). 74 | 75 | Definition main : m unit := 76 | s <- parse_stream;; 77 | z <- search s;; 78 | print z. 79 | 80 | End main. 81 | 82 | Import SimpleIO. 83 | 84 | Definition exec : io_unit := IO.unsafe_run main. 85 | 86 | Extraction "day01_2.ml" exec. 87 | 88 | 89 | Section spec. 90 | 91 | (* Stream of partial sums: we get the actual frequencies from 92 | a stream of frequency changes. *) 93 | Definition psums : Stream Z -> Stream Z := 94 | Str_scanl Z.add 0%Z. 95 | 96 | (* [dup n xs]: The [n]-th element of [xs] already occured before. *) 97 | Definition dup {A : Type} (n : nat) (xs : Stream A) : Prop := 98 | List.In (Str_nth n xs) (Str_take n xs). 99 | 100 | (* [first_dup n xs]: The [n]-th element is the first duplicate. *) 101 | Definition first_dup {A : Type} (n : nat) (xs : Stream A) : Prop := 102 | dup n xs /\ 103 | forall m, m < n -> ~ dup m xs. 104 | 105 | (* [main] outputs the value of the first duplicate, if there is one. *) 106 | (* TODO: we can also add that, if [main] terminates, then the output 107 | is indeed the first duplicate (which thus exists). *) 108 | Definition correct (main : io_rel Z Z unit) : Prop := 109 | forall zs xs n, 110 | cycle zs = Some xs -> 111 | first_dup n (psums xs) -> 112 | rel_spec Z Z main zs [Str_nth n (psums xs)]. 113 | 114 | Lemma ZSet_In_add z z' s : 115 | ZSet.In z (ZSet.add z' s) <-> z = z' \/ ZSet.In z s. 116 | Proof. 117 | split. 118 | - destruct (Z_as_OT.eq_dec z z'). 119 | + auto. 120 | + right; eapply ZSet.add_3; eauto. 121 | - intros []. 122 | + apply ZSet.add_1; auto. 123 | + apply ZSet.add_2; auto. 124 | Qed. 125 | 126 | Lemma or_iff_distrib : 127 | forall A B C D, (A <-> C) -> (B <-> D) -> (A \/ B <-> C \/ D). 128 | Proof. 129 | firstorder. 130 | Qed. 131 | 132 | (* Specification of [search]: if there is a duplicate 133 | position/frequency, return the first one. *) 134 | Theorem search_rel (s0 : io_state Z Z) xs n : 135 | first_dup n (psums xs) -> 136 | search xs s0 s0 (Str_nth n (psums xs)). 137 | Proof. 138 | intros Hdup. 139 | unfold search. 140 | match goal with 141 | | [ |- mfix ?body _ _ _ _ ] => 142 | assert (H : forall 143 | seen pos pre_xs suf_xs s0 i 144 | (Hi : i <= n) 145 | (Hpre : pre_xs = Str_take i (psums xs)) 146 | (Hsuf : suf_xs = Str_nth_tl i xs) 147 | (Hseen : forall x, 148 | ZSet.In x seen <-> List.In x pre_xs) 149 | (Hpos : pos = Str_nth i (psums xs)) 150 | , 151 | lfp_rel1 body (seen, pos, suf_xs) s0 s0 (Str_nth n (psums xs))) 152 | end. 153 | { intros. remember (n - i) as ni eqn:e_ni. 154 | generalize dependent seen. 155 | generalize dependent pos. 156 | generalize dependent pre_xs. 157 | generalize dependent suf_xs. 158 | generalize dependent s0. 159 | generalize dependent i. 160 | induction ni as [| ni IH]; intros; 161 | apply lfp_rel_fold; 162 | destruct suf_xs as [x suf_xs]. 163 | - assert (i = n); [| subst i]. 164 | { symmetry in e_ni. apply Nat.sub_0_le in e_ni. 165 | apply Nat.le_antisymm; auto. } 166 | rewrite ZSet.mem_1. 167 | + simpl; auto. 168 | + destruct Hdup as [Hdup _]. 169 | apply Hseen. 170 | rewrite Hpos, Hpre. 171 | auto. 172 | - assert (Hi' : i < n). 173 | { apply lt_O_minus_lt. 174 | rewrite <- e_ni. 175 | apply Nat.lt_0_succ. 176 | } 177 | assert (Hmem : ZSet.mem pos seen = false). 178 | { destruct Hdup as [Hdup Hnodup]. 179 | apply Bool.not_true_is_false. 180 | intro Hmem_contra. 181 | apply ZSet.mem_2 in Hmem_contra. 182 | eapply Hnodup; eauto. 183 | unfold dup. 184 | rewrite <- Hpre, <- Hpos. 185 | apply Hseen; auto. 186 | } 187 | rewrite Hmem. 188 | eapply IH with (i := S i); auto. 189 | + rewrite Nat.sub_succ_r, <- e_ni; auto. 190 | + rewrite Str_nth_tl_S, <- Hsuf. 191 | reflexivity. 192 | + unfold psums. 193 | rewrite Str_scanl_S. 194 | f_equal; auto. 195 | apply (f_equal (@hd _)) in Hsuf; auto. 196 | + intro z. rewrite ZSet_In_add. 197 | rewrite Hseen. 198 | rewrite Str_take_S. 199 | rewrite in_app_iff. 200 | rewrite or_comm. 201 | rewrite <- Hpre. 202 | rewrite <- Hpos. 203 | simpl. 204 | intuition. 205 | } 206 | simpl in *. 207 | apply H with (pre_xs := []) (i := 0); auto. 208 | { apply Nat.le_0_l. } 209 | { intro x. 210 | split. 211 | - intros Hno_seen; inversion Hno_seen. 212 | - contradiction. 213 | } 214 | Qed. 215 | 216 | (* Final correctness theorem. *) 217 | Theorem correct_main : correct main. 218 | Proof. 219 | intros zs xs n Hzs Hn. 220 | unfold rel_spec. 221 | exists (Mk_io_state [] [Str_nth n (psums xs)]). 222 | split; [| auto]. 223 | unfold main. 224 | exists xs, (Mk_io_state [] []); split. 225 | { (* parse_stream *) 226 | unfold parse_stream. 227 | exists zs, (Mk_io_state [] []); split. 228 | { (* read_all *) apply read_all_rel; auto. } 229 | { rewrite Hzs; simpl; auto. } 230 | } 231 | exists (Str_nth n (psums xs)), (Mk_io_state [] []); split. 232 | { (* search *) 233 | apply search_rel; auto. 234 | } 235 | hnf; auto. 236 | Qed. 237 | 238 | End spec. 239 | -------------------------------------------------------------------------------- /SUMMARY.md: -------------------------------------------------------------------------------- 1 | # The Advent of Code in Coq: Project summary 2 | 3 | Programming challenges like the Advent of Code usually focus more 4 | on algorithmic content, keeping IO to the bare minimum. Thus, a 5 | traditional approach would be to similarly concentrate on verifying 6 | pure functions at the core of the given problem. In contrast, this 7 | project aims to cover IO handling, to get closer to the ideal of a 8 | "complete certification". In spite of the simple format of the Advent 9 | of Code, formally specifying the IO interface in a satisfactory way 10 | took quite some trial and error, even with significant simplifications. 11 | 12 | ## Challenges 13 | 14 | ### How to do IO in Coq? 15 | 16 | At its core, Coq is only a very expressive lambda calculus, with 17 | no notion of IO to speak of. One standard way to "run" Coq terms 18 | is to extract them to OCaml (also SML and Haskell). This is well 19 | adapted to implement pure algorithms in Coq and link them in OCaml, 20 | but we can also use extraction to declare abstract primitives that 21 | extract to whatever OCaml code we want. That way, Coq has a somewhat 22 | practical FFI story. 23 | 24 | Using that mechanism, I created 25 | [coq-simple-io](https://github.com/Lysxia/coq-simple-io) to define 26 | an IO monad mimicking Haskell. 27 | 28 | ### How to verify IO programs? 29 | 30 | As the documentation of coq-simple-io indicates, verification-wise, 31 | it comes with no batteries. The idea is to keep it light so it can 32 | be plugged into various verification frameworks without regret, 33 | since, AFAICT, there is no One True Way of verifying IO programs. 34 | 35 | But still, without verification, this project would not be too 36 | different from doing it in OCaml directly. So let's try verifying 37 | our solutions! An expected side product of this project is a 38 | little verification framework suitable for programming challenges 39 | like the Advent of Code. 40 | 41 | As with any verification project, there is no way to get 100% 42 | confidence: there will always be some unchecked component to be 43 | trusted, and experience shows that, the more you verify, the harder 44 | it gets to verify the rest. 45 | Thus we have to pick our battles. For this project, the battle 46 | stops at parsing. The Advent of Code solutions use and trust a 47 | simple API with structured inputs/outputs, e.g., with `Z`: 48 | 49 | ```coq 50 | (* [lib/io.v] *) 51 | Parameter read : IO Z. 52 | Parameter print : Z -> IO unit. 53 | ``` 54 | 55 | In fact, the API is parameterized by the types of inputs and outputs, 56 | which may thus change for each problem. For example, Day 1 deals with 57 | signed integers, and Day 2 deals with strings. 58 | 59 | The current implementations of `read` actually process the input 60 | line by line, so in a way, we are still handling a small aspect of 61 | parsing. 62 | 63 | For verification, we model the `IO` monad as a "State monad" 64 | `IO A = io_state -> io_state * A` for some type `io_state` 65 | representing a simple world: 66 | 67 | ```coq 68 | (* [lib/rel.v] *) 69 | Record io_state I O := Mk_io_state { 70 | input : list I; 71 | output : list O; 72 | }. 73 | ``` 74 | 75 | There is one little issue: the API comprises a general fixpoint 76 | combinator: 77 | 78 | ```coq 79 | (* coq-ext-lib library *) 80 | Class MonadFix (m : Type -> Type) : Type := { 81 | mfix : forall A B, ((A -> m B) -> (A -> m B)) -> A -> m B; 82 | }. 83 | ``` 84 | 85 | This `mfix` cannot be implemented for a pure state monad in Coq. 86 | After many failed attempts (some of which are recorded in 87 | `lib/mock.v` and `lib/mock_spec.v` for posterity, but also because 88 | I hope to figure them out one day), I've currently settled for 89 | defining partial functions as relations (big-step style): 90 | 91 | ```coq 92 | (* [lib/rel.v] *) (* This is a monad. *) 93 | Definition io_rel I O A := 94 | io_state I O -> io_state I O -> A -> Prop. 95 | ``` 96 | 97 | The definition of `mfix` is still non-trivial IMO, but users don't 98 | have to see it, they only need to know that it defines a fixed point, 99 | with the obvious law: `mfix f = f (mfix f)`. 100 | 101 | Now, our solutions are monadic programs, of which the monad is a 102 | parameter. Using regular `IO`, we get executables via extraction. 103 | Using the `io_rel` monad shown just above, we get an abstract model 104 | of the program as a partial function (morally 105 | `io_state -> io_state * A`). 106 | 107 | A toplevel `main` program only has a `unit` return type: any output 108 | should be printed, not returned. We thus obtain a relation between 109 | inputs and outputs: 110 | 111 | ```coq 112 | (* [lib/rel.v] *) 113 | Definition rel_spec I O : 114 | io_rel I O unit -> list I -> list O -> Prop. 115 | ``` 116 | 117 | A specification is a property of that model: 118 | 119 | ```coq 120 | Definition specification I O : (list I -> list O -> Prop) -> Prop. 121 | (* That definition does not actually appear in the code. *) 122 | ``` 123 | 124 | *(Advent of Code Spoilers ahead.)* 125 | 126 | To take the example of day 1 (part one), we show that the `main` 127 | program implements the function that sums a list of integers: 128 | as a relation, it must relate a list `zs` to a singleton list of 129 | `sum_Z zs`. 130 | 131 | ```coq 132 | (* [day01_1.v] *) 133 | Theorem correct_main : 134 | forall zs, rel_spec Z Z main zs [sum_Z zs]. 135 | ``` 136 | 137 | Regarding the question of termination, this is a total correctness 138 | theorem: any output in the codomain of the relation `main` means 139 | that, on the corresponding input, the program *will* terminate and 140 | produce that output. 141 | 142 | I hope that gave you a taste of the kind of properties we can verify 143 | in this project. 144 | 145 | ## Formalization gap 146 | 147 | Verification efforts should make explicit the components they trust, 148 | to avoid a false sense of security that comes with the currently 149 | uncommon usage of formal verification, and more importantly to 150 | clarify the scope of the verification results, which might also 151 | reveal weaknesses worth reinforcing. 152 | 153 | If you spot anything missing from this section, please open an issue! 154 | 155 | The link between `IO` and `io_rel` (i.e., that `io_rel` properly 156 | models `IO`, at least in this simple setting) is part of the trusted 157 | base. In any case, since `IO` is defined via extraction, it would not 158 | be possible to verify that link without significant effort (there's 159 | at least a full thesis to write on that topic). A relevant project 160 | to mention here is 161 | [CertiCoq](https://www.cs.princeton.edu/~appel/certicoq/), 162 | a verified compiler for Coq. 163 | 164 | A more feasible task would be to verify the multiple variants of 165 | `read`/`print` functions currently in use, against a smaller number 166 | of trusted primitives and a uniform model of `IO` (that avoids the 167 | `I` and `O` parameters of `io_rel`). My guess is this would 168 | significantly complicate the current model, for quickly diminishing 169 | returns, but I can be convinced otherwise. 170 | 171 | ## Repo organization 172 | 173 | - In every `day*_*.v` file: the `main` program to be executed, 174 | a `correct`-ness theorem, and a proof `correct_main`. 175 | 176 | - `lib.v`: reexports code under `lib/`, general-purpose definitions 177 | reusable by different solutions. 178 | 179 | + `lib/io.v`: IO interface used by the solutions. 180 | + `lib/rel.v`: modelling IO as a relation (or partial function) 181 | between inputs and outputs. 182 | + `lib/string.v`, `lib/stream.v`, `lib/utils.v`: 183 | various utilities complementing the stdlib. 184 | + `lib/mock.v`, `lib/mock_spec.v`: more functional/computational 185 | models of IO (WIP/failed experiment). 186 | -------------------------------------------------------------------------------- /sol/day02_1.v: -------------------------------------------------------------------------------- 1 | Set Warnings "-extraction-opaque-accessed". 2 | 3 | From Coq Require Import 4 | List Arith Ascii String 5 | OrderedTypeEx FMapAVL 6 | extraction.ExtrOcamlIntConv. 7 | Import ListNotations. 8 | 9 | From SimpleIO Require SimpleIO. 10 | 11 | From ExtLib Require Import 12 | Structures.Monads. 13 | Import MonadNotation. 14 | Local Open Scope monad. 15 | 16 | From advent Require Import lib. 17 | 18 | Module Algorithm (Import OT : OrderedType.OrderedType). 19 | 20 | Module Map := FMapAVL.Make OT. 21 | 22 | (* Interpret a finite map [Map.t nat] as a function [t -> nat], 23 | defaulting to 0 outside of its support. *) 24 | Definition lookup (count : Map.t nat) : t -> nat := 25 | fun x : t => 26 | match Map.find x count with 27 | | None => 0 28 | | Some n => n 29 | end. 30 | 31 | (* Increment the value associated to [x] by one. *) 32 | Definition increment (x : t) : Map.t nat -> Map.t nat := 33 | fun count => Map.add x (1 + lookup count x) count. 34 | 35 | (* [collect xs] gives, for every element [x : t], the number 36 | of times it occues in [xs]. *) 37 | Definition collect (xs : list t) : Map.t nat := 38 | fold_left 39 | (fun count x => increment x count) 40 | xs 41 | (Map.empty nat). 42 | 43 | (* Now it is straightforward to determine whether some element 44 | occurs two or three times in the list [xs]. *) 45 | Definition two_or_three (xs : list t) : bool * bool := 46 | Map.fold (fun _ n tot => 47 | (fst tot || (n =? 2), snd tot || (n =? 3))%bool) 48 | (collect xs) 49 | (false, false). 50 | 51 | End Algorithm. 52 | 53 | Module Import A := Algorithm Ascii_OT. 54 | 55 | Section main. 56 | 57 | Context {m : Type -> Type} `{Monad m} 58 | `{FoldRead (list ascii) m} `{MonadO nat m}. 59 | 60 | (* We have two counters for the numbers of words containing 61 | two/three of any letter. For each word, [two_or_three] tells us 62 | whether to increment each counter. *) 63 | Definition main : m unit := 64 | '(twos, threes) <- 65 | fold_read (fun '(twos, threes) id => 66 | let tot := two_or_three id in 67 | (if fst tot then 1+twos else twos, 68 | if snd tot then 1+threes else threes)) (0, 0);; 69 | print (twos * threes). 70 | 71 | End main. 72 | 73 | Import SimpleIO. 74 | 75 | Definition exec : io_unit := IO.unsafe_run main. 76 | 77 | Extraction "day02_1.ml" exec. 78 | 79 | Section spec. 80 | 81 | (* We first formalize the property of having exactly two/three 82 | of a given letter. *) 83 | 84 | (* The number of occurences of [c] in [xs]. *) 85 | Definition n_occurs (c : ascii) (xs : list ascii) : nat := 86 | List.length (filter (eqb_ascii c) xs). 87 | 88 | (* [has_n n xs : Prop] holds when some letter appears in [xs] 89 | exactly [n] times. *) 90 | Definition has_n (n : nat) (xs : list ascii) : Prop := 91 | exists c, n_occurs c xs = n. 92 | 93 | Definition has_two : list ascii -> Prop := has_n 2. 94 | Definition has_three : list ascii -> Prop := has_n 3. 95 | 96 | (* The meat of the program: [two_or_three]. 97 | 98 | We first state the specification of [two_or_three], and then prove 99 | properties about the surrounding auxiliary functions until 100 | we can prove that spec. *) 101 | 102 | (* The two booleans of [two_or_three] tell us whether there are 103 | elements occuring two/three times in the list [xs]. *) 104 | Definition two_or_three_spec : Prop := 105 | forall xs : list ascii, 106 | (fst (two_or_three xs) = true <-> has_two xs) /\ 107 | (snd (two_or_three xs) = true <-> has_three xs). 108 | 109 | Lemma increment_plus_one x count : 110 | lookup (increment x count) x = S (lookup count x). 111 | Proof. 112 | unfold increment, lookup. 113 | destruct (Map.find x count) as [n |] eqn:e_find. 114 | - apply Map.find_2 in e_find. 115 | erewrite Map.find_1; [eauto |]. 116 | apply Map.add_1; auto. 117 | - erewrite Map.find_1; [eauto |]. 118 | apply Map.add_1; auto. 119 | Qed. 120 | 121 | Lemma Map_find_None {A : Type} y (m : Map.t A) : 122 | (forall e, ~ Map.MapsTo y e m) <-> Map.find y m = None. 123 | Proof. 124 | split. 125 | - intros H. destruct Map.find as [a | ] eqn:e_find; auto. 126 | apply Map.find_2 in e_find. firstorder. 127 | - intros H e HM. apply Map.find_1 in HM. 128 | rewrite HM in H. discriminate. 129 | Qed. 130 | 131 | Lemma Map_add_neq {A : Type} (m : Map.t A) (x y : Map.key) (e e' : A) : 132 | x <> y -> (Map.MapsTo y e (Map.add x e' m) <-> Map.MapsTo y e m). 133 | Proof. 134 | split. { apply Map.add_3; auto. } { apply Map.add_2; auto. } 135 | Qed. 136 | 137 | Lemma Map_find_add_neq {A : Type} (m : Map.t A) x y e : 138 | x <> y -> Map.find y (Map.add x e m) = Map.find y m. 139 | Proof. 140 | intros Hneq. 141 | destruct (Map.find y m) as [e' |] eqn:e_find. 142 | - apply Map.find_1, Map.add_2, Map.find_2; auto. 143 | - apply Map_find_None. 144 | intros e' HM. 145 | apply Map.add_3 in HM; auto. 146 | apply Map.find_1 in HM. 147 | rewrite HM in e_find. discriminate. 148 | Qed. 149 | 150 | Lemma increment_id x y count : 151 | x <> y -> lookup (increment x count) y = lookup count y. 152 | Proof. 153 | intro Hneq. 154 | unfold increment, lookup. 155 | destruct (Map.find y count) as [n |] eqn:e_find. 156 | - erewrite Map.find_1; [eauto |]. 157 | apply Map.add_2; auto. 158 | apply Map.find_2; auto. 159 | - rewrite Map_find_add_neq; auto. 160 | rewrite e_find; auto. 161 | Qed. 162 | 163 | (* A translation and proof of the specification of [collect] 164 | stated earlier. *) 165 | Lemma collect_correct : 166 | forall xs c, lookup (collect xs) c = n_occurs c xs. 167 | Proof. 168 | unfold collect. 169 | assert (H : forall xs c (count : Map.t nat), 170 | lookup (fold_left 171 | (fun count x => increment x count) 172 | xs 173 | count) c = n_occurs c xs + lookup count c). 174 | { induction xs as [| x xs]; simpl; auto. 175 | intros c count. 176 | unfold n_occurs. simpl. 177 | destruct eqb_ascii eqn:e_cx. 178 | - apply eqb_eq in e_cx; subst. 179 | simpl. 180 | rewrite <- Nat.add_succ_r. 181 | rewrite <- increment_plus_one. 182 | apply IHxs. 183 | - rewrite neqb_neq in e_cx. 184 | erewrite <- (increment_id _ _ count); eauto. 185 | } 186 | intros. 187 | specialize (H xs c (Map.empty nat)); unfold lookup in H; simpl in H. 188 | rewrite plus_0_r in H. 189 | auto. 190 | Qed. 191 | 192 | Lemma fold_left_ind {A B : Type} (P : list A -> B -> B -> Prop) 193 | (f : B -> A -> B) 194 | (Hnil : forall y, P [] y y) 195 | (Hcons : forall x xs y y', P xs (f y x) y' -> P (x :: xs) y y') : 196 | forall xs y, 197 | P xs y (fold_left f xs y). 198 | Proof. 199 | induction xs as [| x xs]; auto. 200 | simpl; firstorder. 201 | Qed. 202 | 203 | Theorem two_or_three_correct : two_or_three_spec. 204 | Proof. 205 | intro xs. 206 | remember (two_or_three xs) as ttx eqn:ettx. 207 | unfold two_or_three in ettx. 208 | rewrite Map.fold_1 in ettx. 209 | match type of ettx with 210 | | (_ = fold_left ?f _ _) => 211 | assert (H : forall xs y, 212 | (fst (fold_left f xs y) = true <-> 213 | (exists c, List.In (c, 2) xs) \/ fst y = true)) 214 | end. 215 | { clear. 216 | induction xs; intros [t1 t2]. 217 | - firstorder. 218 | - simpl. split. 219 | + intro H0. 220 | apply IHxs in H0. simpl in H0. 221 | destruct H0 as [[c H0] | H0]. 222 | * firstorder. 223 | * apply Bool.orb_prop in H0. 224 | destruct H0; auto. 225 | rewrite Nat.eqb_eq in H. 226 | destruct a as [c p]; left; exists c. auto. 227 | + intros H0. apply IHxs. 228 | destruct H0 as [[c [H | H]]| H]. 229 | * subst a; auto. simpl. rewrite Bool.orb_true_r; auto. 230 | * left. exists c; auto. 231 | * subst; auto. 232 | } 233 | split. 234 | - subst ttx. rewrite H. 235 | split. 236 | + intros [[c Hc]|]; [| discriminate]. 237 | exists c. 238 | rewrite <- collect_correct. 239 | unfold lookup. 240 | erewrite Map.find_1; auto. 241 | apply Map.elements_2, SetoidList.In_InA; auto. 242 | typeclasses eauto. 243 | + intros [c Hc]. left. 244 | rewrite <- collect_correct in Hc. 245 | unfold lookup in Hc. 246 | destruct Map.find eqn:ec in Hc; [| discriminate]. 247 | exists c. 248 | apply Map.find_2 in ec. 249 | apply Map.elements_1 in ec. 250 | apply SetoidList.InA_alt in ec. 251 | destruct ec as [[c' n'] []]. 252 | inversion H0; simpl in *; subst; auto. 253 | - admit. 254 | Abort. 255 | 256 | End spec. 257 | -------------------------------------------------------------------------------- /lib/rel.v: -------------------------------------------------------------------------------- 1 | (* Here we model IO as a partial function between input and output 2 | states: [IO a ~ (io_state -> io_state * a)], actually 3 | implemented as [io_state -> io_state -> a -> Prop]. 4 | 5 | Partiality is caused by the presence of a general (monadic) 6 | fixpoint combinator ([mfix]). 7 | *) 8 | 9 | From Coq Require Import 10 | List ZArith String 11 | RelationClasses 12 | extraction.ExtrOcamlIntConv. 13 | Import ListNotations. 14 | 15 | From Coq.extraction Require Import 16 | ExtrOcamlIntConv. 17 | 18 | From ExtLib Require Import 19 | Data.Monads.OptionMonad 20 | Structures.Monads. 21 | 22 | From advent.lib Require Import 23 | io utils. 24 | 25 | (* First, some general definitions about state [S -> (S * A)]. 26 | We then specialize [S] to a simple model of IO state. *) 27 | 28 | (* [state_rel]: state [S -> (S * A)] as a relation. *) 29 | Definition state_rel (S : Type) (A : Type) : Type := 30 | S -> S -> A -> Prop. 31 | 32 | (* [state_rel] is a monad. *) 33 | Instance Monad_state_rel (S : Type) : Monad (state_rel S) := { 34 | ret _ x := fun s1 s2 x' => s2 = s1 /\ x' = x; 35 | bind _ _ m k := fun s1 s3 y => 36 | exists x s2, m s1 s2 x /\ k x s2 s3 y 37 | }. 38 | 39 | (* Errors are modelled by the empty relation. *) 40 | Instance MonadError_state_rel (S : Type) : MonadError (state_rel S) := { 41 | error _ _ := fun _ _ _ => False 42 | }. 43 | 44 | (* Relations are preordered by implication. *) 45 | Definition incl_rel {S A : Type} (r1 r2 : state_rel S A) := 46 | forall s1 s2 a, r1 s1 s2 a -> r2 s1 s2 a. 47 | 48 | (* Logical equivalence. *) 49 | Definition eq_rel {S A : Type} (r1 r2 : state_rel S A) := 50 | incl_rel r1 r2 /\ incl_rel r2 r1. 51 | 52 | Instance Transitive_incl_rel {S A} : Transitive (@incl_rel S A). 53 | Proof. firstorder. Qed. 54 | 55 | Instance Transitive_eq_rel {S A} : Transitive (@eq_rel S A). 56 | Proof. firstorder. Qed. 57 | 58 | (* For [mfix], we will be manipulating relations with an extra 59 | parameter: [A -> S -> S -> B -> Prop]. *) 60 | Definition incl_rel1 {S A B : Type} 61 | (r1 r2 : A -> state_rel S B) := 62 | forall x, incl_rel (r1 x) (r2 x). 63 | 64 | (* Reflexivity of [incl_rel1]. *) 65 | Lemma incl_rel1_refl {S A B : Type} (r : A -> state_rel S B) : 66 | incl_rel1 r r. 67 | Proof. 68 | intros x z1 z2 y; auto. 69 | Qed. 70 | 71 | (* Least fixed point of the "relation transformer", [gf] (or 72 | "generating function"; note how it maps relations to relations). 73 | [gf] is assumed to be monotonic (see below). 74 | Definition inspired by [paco] (https://github.com/snu-sf/paco). *) 75 | Inductive lfp_rel1 {S A B : Type} 76 | (gf : (A -> state_rel S B) -> (A -> state_rel S B)) 77 | (a : A) (s1 s2 : S) (b : B) : Prop := 78 | | LFP 79 | (P : A -> state_rel S B) 80 | (P_ind : incl_rel1 P (lfp_rel1 gf)) 81 | (P_holds : gf P a s1 s2 b). 82 | 83 | (* [monotonic_rel1 gf : Prop] : the relation transformer [gf] 84 | is monotonic. *) 85 | Definition monotonic_rel1 {S U V A B : Type} 86 | (gf : (U -> state_rel S V) -> (A -> state_rel S B)) := 87 | forall r1 r2, 88 | incl_rel1 r1 r2 -> 89 | incl_rel1 (gf r1) (gf r2). 90 | 91 | (* [lfp_rel1 gf] is included in [gf (lfp_rel1 gf)]... *) 92 | Lemma lfp_rel_unfold {S A B : Type} 93 | (gf : (A -> state_rel S B) -> (A -> state_rel S B)) 94 | (mon_gf : monotonic_rel1 gf) : 95 | incl_rel1 (lfp_rel1 gf) (gf (lfp_rel1 gf)). 96 | Proof. 97 | intros x z1 z2 y [P P_ind P_holds]. 98 | eapply mon_gf. 99 | apply P_ind. 100 | apply P_holds. 101 | Qed. 102 | 103 | (* ... and conversely. Therefore, [lfp_rel1] does define a fixed 104 | point... *) 105 | Lemma lfp_rel_fold {S A B : Type} 106 | (gf : (A -> state_rel S B) -> (A -> state_rel S B)) : 107 | incl_rel1 (gf (lfp_rel1 gf)) (lfp_rel1 gf). 108 | Proof. 109 | intros x z1 z2 y Hgf. 110 | apply LFP with (P := lfp_rel1 gf). 111 | apply incl_rel1_refl. 112 | auto. 113 | Qed. 114 | 115 | (* ... and it is in fact the smallest: every other fixed point [fp] 116 | contains [lfp_rel1 gf]. *) 117 | Lemma really_lfp {S A B : Type} 118 | (gf : (A -> state_rel S B) -> (A -> state_rel S B)) 119 | (mon_gf : monotonic_rel1 gf) 120 | (fp : A -> state_rel S B) 121 | (H_fp : incl_rel1 (gf fp) fp) : 122 | incl_rel1 (lfp_rel1 gf) fp. 123 | Proof. 124 | intros x z1 z2 y. 125 | induction 1 as [x z1 z2 y P P_ind IH P_holds]. 126 | apply H_fp. 127 | apply mon_gf with (r1 := P); auto. 128 | Qed. 129 | 130 | (* Fixed-point semantics for [mfix]. *) 131 | Instance MonadFix_state_rel (S : Type) : MonadFix (state_rel S) := { 132 | mfix _ _ := lfp_rel1 133 | }. 134 | 135 | (* Utilities to prove monotonicity. *) 136 | 137 | Lemma monotonic_refl (S U V W A : Type) 138 | (m : state_rel S A) : 139 | monotonic_rel1 (fun (_ : U -> _ V) (_ : W) => m). 140 | Proof. 141 | unfold monotonic_rel1, incl_rel1, incl_rel; auto. 142 | Qed. 143 | 144 | Lemma monotonic_id (S U V W : Type) 145 | (g : W -> U) : 146 | monotonic_rel1 (fun (f : U -> state_rel S V) (w : W) => f (g w)). 147 | Proof. 148 | unfold monotonic_rel1, incl_rel1; auto. 149 | Qed. 150 | 151 | Lemma monotonic_ret (S U V W A : Type) 152 | (g : W -> A) : 153 | monotonic_rel1 (fun (f : U -> state_rel S V) (w : W) => ret (g w)). 154 | Proof. 155 | unfold monotonic_rel1, incl_rel1, incl_rel; auto. 156 | Qed. 157 | 158 | Lemma monotonic_bind (S U V W A B : Type) 159 | (m : (U -> state_rel S V) -> W -> state_rel S A) 160 | (k : (U -> state_rel S V) -> W -> A -> state_rel S B) 161 | (mon_m : monotonic_rel1 m) 162 | (mon_k : forall a, monotonic_rel1 (fun f w => k f w a)) : 163 | monotonic_rel1 (fun f w => pbind (m f w) (k f w)). 164 | Proof. 165 | intros r1 r2 Hr12 w s1 s3 b [a [s2 [Hm Hk]]]. 166 | exists a, s2. 167 | firstorder. 168 | specialize (mon_k a). 169 | unfold monotonic_rel1 in mon_k. 170 | eapply mon_k; eauto. 171 | Qed. 172 | 173 | (* Modelling [IO]. *) 174 | 175 | (* We represent IO state as a sequence of inputs and a sequence 176 | of outputs. For problems like AoC that should be quite enough. 177 | The input and output types are parameters: we trust the 178 | parsing/printing done by [read]/[print], there is still quite 179 | some space left to play with verification. 180 | *) 181 | Record io_state (I O : Type) := Mk_io_state { 182 | input : list I; 183 | output : list O; 184 | }. 185 | 186 | Arguments Mk_io_state {I O} _ _. 187 | Arguments input {I O} _. 188 | Arguments output {I O} _. 189 | 190 | (* Construct an initial state from an initial input sequence. *) 191 | Definition initial {I O : Type} (i : list I) : io_state I O := 192 | Mk_io_state i []. 193 | 194 | (* Update the state on a [read]. *) 195 | Definition drop_input {I O : Type} (r : io_state I O) : io_state I O := 196 | let '(Mk_io_state i o) := r in 197 | Mk_io_state (tl i) o. 198 | 199 | (* Update the state on a [print]. *) 200 | Definition push_output {I O : Type} 201 | (z : O) (r : io_state I O) : io_state I O := 202 | let '(Mk_io_state i o) := r in 203 | Mk_io_state i (o ++ [z]). 204 | 205 | (* [state_rel] specialized with [io_state]. *) 206 | Definition io_rel (I O : Type) : Type -> Type := 207 | state_rel (io_state I O). 208 | 209 | (* Toplevel specification, we model an [IO unit] program 210 | as a relation between inputs and outputs. *) 211 | Definition rel_spec (I O : Type) : 212 | io_rel I O unit -> list I -> list O -> Prop := 213 | fun x i o => 214 | exists s, 215 | x (initial i) s tt /\ 216 | output s = o. 217 | 218 | (* Model [read] in [io_rel]. *) 219 | Instance MonadI_io_rel (I O : Type) : MonadI I (io_rel I O) := { 220 | read := fun s1 s2 x' => 221 | (exists z, 222 | input s1 = z :: input s2 /\ 223 | s2 = drop_input s1 /\ 224 | x' = Some z) \/ 225 | (input s1 = [] /\ s2 = s1 /\ x' = None); 226 | }. 227 | 228 | (* Model [print] in [io_rel]. *) 229 | Instance MonadO_io_rel (I O : Type) : MonadO O (io_rel I O) := { 230 | print z := fun s1 s2 x' => 231 | s2 = push_output z s1 /\ 232 | x' = tt 233 | }. 234 | 235 | (* Specification of [fold_read]. *) 236 | Lemma fold_read_rel {I O A : Type} (f : A -> I -> A) (a0 : A) : 237 | eq_rel (fold_read f a0) 238 | (fun (s1 s2 : io_state I O) (a1 : A) => 239 | a1 = fold_left f (input s1) a0 /\ 240 | s2 = Mk_io_state [] (output s1)). 241 | Proof. 242 | split. 243 | - intros s1 s2 xs. 244 | unfold fold_read, FoldRead_MonadFix. 245 | match goal with 246 | | [ |- mfix ?body _ _ _ _ -> _ ] => 247 | assert (mon_body : monotonic_rel1 body) 248 | end. 249 | { apply monotonic_bind. 250 | - apply monotonic_refl. 251 | - intros [i|]. 252 | { apply monotonic_id. } 253 | { apply monotonic_ret. } 254 | } 255 | match goal with 256 | | [ |- mfix ?body _ _ _ _ -> _ ] => 257 | assert (H : forall acc s1 s2 a1, 258 | lfp_rel1 body acc s1 s2 a1 -> 259 | a1 = fold_left f (input s1) acc /\ 260 | s2 = Mk_io_state [] (output s1)); [|auto] 261 | end. 262 | { revert mon_body; clear; intros mon_body acc [is1 os1]. 263 | revert acc. induction is1 as [| i1 is1]; intros acc s2 xs Hloop. 264 | - apply lfp_rel_unfold in Hloop; auto. 265 | destruct Hloop as [ox [s1' [Hread Hloop]]]. 266 | destruct Hread as [[i1 [Hi1]] | [Hi [Hs1' Hox]]]. 267 | + discriminate Hi1. 268 | + subst ox. 269 | destruct Hloop; subst; auto. 270 | - apply lfp_rel_unfold in Hloop; auto. 271 | destruct Hloop as [ox [s1' [Hread Hloop]]]. 272 | destruct Hread as [[i1' [Hi1 [Hs1' Hox]]] | [Hs1' Hox]]. 273 | + subst ox s1'. 274 | simpl in Hi1; inversion Hi1; subst. 275 | apply IHis1 in Hloop. 276 | destruct Hloop as [Hxs Hs2]. subst. 277 | auto. 278 | + discriminate. 279 | } 280 | - intros s1 s2 a1 [Ha1 Hs2]. 281 | unfold fold_read, FoldRead_MonadFix. 282 | match goal with 283 | | [ |- mfix ?body _ _ _ _ ] => 284 | assert (H : forall acc s1 s2 a1, 285 | a1 = fold_left f (input s1) acc -> 286 | s2 = Mk_io_state [] (output s1) -> 287 | lfp_rel1 body acc s1 s2 a1); [| apply H; auto] 288 | end. 289 | { clear. 290 | intros acc s1. revert acc. 291 | remember (input s1) as is1 eqn:Hs1. 292 | generalize dependent s1. 293 | induction is1 as [|i1 is1 IH]; 294 | intros s1 Hs1 acc s2 xs His1 Hs2; 295 | apply lfp_rel_fold. 296 | + exists None, s2. 297 | split. 298 | * right; destruct s1, s2; simpl in *; subst; auto. 299 | * simpl; auto. 300 | + exists (Some i1), (Mk_io_state is1 (output s1)). 301 | split. 302 | * left. exists i1. simpl. 303 | destruct s1; simpl in *; subst; auto. 304 | * apply IH; auto. 305 | } 306 | Qed. 307 | 308 | (* Specification of [read_all]: it consumes all the input and 309 | returns it in a list. *) 310 | Lemma read_all_rel {I O : Type} : 311 | eq_rel read_all 312 | (fun (s1 s2 : io_state I O) xs => 313 | xs = input s1 /\ 314 | s2 = Mk_io_state [] (output s1)). 315 | Proof. 316 | split; intros s1 s2 a1. 317 | - intros [is1' [s1' [H1' [? ?]]]]; subst. 318 | apply fold_read_rel in H1'. 319 | rewrite fold_left_cons in H1'. 320 | destruct H1'; subst. 321 | unfold rev'; rewrite <- rev_alt, rev_involutive. 322 | auto. 323 | - intros [? ?]; subst. 324 | exists (rev (input s1)). eexists. 325 | split. 326 | + apply fold_read_rel. 327 | split. 328 | * rewrite fold_left_cons; auto. 329 | * reflexivity. 330 | + unfold rev'; rewrite <- rev_alt, rev_involutive. 331 | simpl; auto. 332 | Qed. 333 | -------------------------------------------------------------------------------- /sol/day05_common.v: -------------------------------------------------------------------------------- 1 | (* In this file: 2 | 3 | - [react]: a function to fully reduce a polymer. 4 | 5 | - [react_f]: the core of [react], extracted for 6 | use with other folds (partic. [io.fold_read]). 7 | 8 | - [react_step]: a declarative definition of an 9 | elementary reaction. Not executable but obviously 10 | faithful to the problem description. 11 | 12 | - [react_steps_injective]: a proof that all sequences 13 | of [react_step] lead to the same normal form. 14 | This shows that the puzzle's answer is unique. 15 | 16 | - [react_correct]: a proof that the function [react] 17 | implements the specification [react_step]. 18 | *) 19 | 20 | Set Warnings "-extraction-opaque-accessed". 21 | 22 | From Coq Require Import 23 | Ascii String List Arith 24 | OrderedTypeEx FMapAVL 25 | Sets.Relations_3_facts 26 | Relations.Relations 27 | extraction.ExtrOcamlIntConv. 28 | Import ListNotations. 29 | 30 | From SimpleIO Require SimpleIO. 31 | 32 | From ExtLib Require Import 33 | Structures.Monads. 34 | Import MonadNotation. 35 | Local Open Scope monad. 36 | 37 | From advent Require Import lib. 38 | 39 | Import SimpleIO. 40 | 41 | (* Byte-by-byte input. *) 42 | Instance MonadI_int_IO : MonadI int IO := { 43 | read := 44 | (* Stop reading at the first newline. *) 45 | c <- input_byte stdin;; 46 | ret (if (c =? int_of_nat 10)%int then 47 | None 48 | else 49 | Some c); 50 | }. 51 | 52 | (* For debugging *) 53 | Instance MonadO_list_int_IO : MonadO int IO := { 54 | print := output_byte stdout; 55 | }. 56 | 57 | Definition reactable (c1 c2 : int) : bool := 58 | int_eqb (lxor c1 c2) 59 | (int_of_nat 32). 60 | 61 | Definition react_f (stack : list int) (c : int) : list int := 62 | match stack with 63 | | [] => [c] 64 | | c' :: stack' => 65 | if reactable c c' then 66 | stack' 67 | else 68 | c :: stack 69 | end. 70 | 71 | Definition rev_react (cs : list int) : list int := 72 | fold_left react_f cs []. 73 | 74 | Definition react (cs : list int) : list int := 75 | rev (rev_react cs). 76 | 77 | Section spec. 78 | 79 | Ltac gd xs := 80 | match xs with 81 | | (?xs, ?x) => generalize dependent x; gd xs 82 | | ?x => generalize dependent x 83 | end. 84 | 85 | Section react_generic. 86 | 87 | Context {A : Type}. 88 | 89 | Class Reactive : Type := 90 | can_react : A -> A -> Prop. 91 | Context `{Reactive}. 92 | 93 | Variant react_step : list A -> list A -> Prop := 94 | | RStep (cs1 : list A) (c1 c2 : A) (cs2 : list A) : 95 | can_react c1 c2 -> 96 | react_step (cs1 ++ c1 :: c2 :: cs2) (cs1 ++ cs2). 97 | 98 | Hint Constructors react_step. 99 | 100 | (* [react_steps x z] holds when [x] can reach [z] after some 101 | number of [react_step]. (Reflexive transitive closure) *) 102 | Definition react_steps := Rstar _ react_step. 103 | 104 | Lemma react_cons_congr1 : 105 | forall c cs1 cs2, 106 | react_step cs1 cs2 -> react_step (c :: cs1) (c :: cs2). 107 | Proof. 108 | intros ? ? ? [cs1 c1 c2 cs2]. 109 | apply (RStep (c :: cs1)); auto. 110 | Qed. 111 | 112 | Lemma react_cons_congr : 113 | forall c cs1 cs2, 114 | react_steps cs1 cs2 -> 115 | react_steps (c :: cs1) (c :: cs2). 116 | Proof. 117 | induction 1. 118 | - constructor. 119 | - econstructor; [|eauto]. apply react_cons_congr1; auto. 120 | Qed. 121 | 122 | Class GoodReactive : Prop := { 123 | (* [can_react] should be an involutive function. *) 124 | can_react_symmetric : 125 | forall a b, can_react a b -> can_react b a; 126 | can_react_function : 127 | forall a b c, can_react a b -> can_react a c -> b = c; 128 | }. 129 | 130 | Context `{GoodReactive}. 131 | 132 | Lemma can_react_cofunction : 133 | forall a b c, can_react a c -> can_react b c -> a = b. 134 | Proof. 135 | intros; eapply can_react_function; eapply can_react_symmetric; eauto. 136 | Qed. 137 | 138 | (* We prove that [react_step] is [Confluent], i.e., the top and left 139 | sides of the following square imply the right and bottom ones. 140 | 141 | cs0 > ... > cs1 142 | v v 143 | ... ... 144 | v v 145 | cs2 > ... > cs3 146 | *) 147 | 148 | (* To prove that [react_step] is confluent: it is sufficient to 149 | show that it is *locally confluent* and *noetherian*. *) 150 | 151 | (* [Locally_confluent]: the top and left sides of the square imply 152 | the right and bottom ones. 153 | 154 | x > y1 155 | v v* 156 | y2 >* z 157 | *) 158 | Lemma Locally_confluent_react_step : Locally_confluent _ react_step. 159 | Proof. 160 | intros cs0 cs1 cs2 H01 H02. 161 | inversion H01; inversion H02; clear H01 H02. 162 | gd (cs0, cs1, cs2, cs5). 163 | induction cs3; simpl; intros. 164 | - destruct cs5 as [|c5' cs5]; simpl in *; subst. 165 | + exists cs1; inversion H5; subst; split; constructor. 166 | + destruct cs5; simpl in *; subst. 167 | * exists cs1; inversion H5; subst. 168 | apply can_react_symmetric in H1. 169 | eapply can_react_function in H1; eauto; subst. 170 | split; constructor. 171 | * exists (cs5 ++ cs6); inversion H5; subst. 172 | split; apply Rstar_contains_R. 173 | -- auto. 174 | -- apply (RStep []); auto. 175 | - destruct cs5; simpl in *. 176 | + destruct cs3; simpl in *; subst. 177 | * exists cs2; inversion H5; subst. 178 | eapply can_react_symmetric, 179 | (can_react_function _ a c2) in H4; eauto. 180 | subst; split; constructor. 181 | * exists (cs3 ++ cs4); inversion H5; subst. 182 | split; apply Rstar_contains_R. 183 | -- apply (RStep []); auto. 184 | -- auto. 185 | + specialize IHcs3 with (cs5 := cs5). 186 | subst; inversion H5; subst; clear H5. 187 | edestruct IHcs3 as [cs7 [Hcs7 Hcs7']]; eauto. 188 | exists (a :: cs7). 189 | split; apply react_cons_congr; auto. 190 | Qed. 191 | 192 | (* [Noetherian]: there is no infinite sequence of steps. 193 | In this case, the length decreases by two with every step. *) 194 | Lemma Noetherian_react_step : Noetherian _ react_step. 195 | Proof. 196 | intros cs. 197 | (* Well-founded induction on [length cs]. *) 198 | remember (length cs) as n; generalize dependent cs; 199 | induction (lt_wf n) as [n Hn IH]. 200 | constructor; intros cs1 Hcs1. 201 | eapply IH; eauto. 202 | destruct Hcs1; subst. 203 | repeat rewrite app_length. 204 | apply Nat.add_lt_mono_l. simpl; auto. 205 | Qed. 206 | 207 | Theorem Confluent_react_step : Confluent _ react_step. 208 | Proof. 209 | apply Newman. 210 | - apply Noetherian_react_step. 211 | - apply Locally_confluent_react_step. 212 | Qed. 213 | 214 | (* As a corollary, fully reacting a polymer yields a unique result, 215 | showing that there is only one possible answer. *) 216 | 217 | (* [cs] is inert if it can no longer react. *) 218 | Definition inert (cs : list A) : Prop := 219 | forall cs', ~ react_step cs cs'. 220 | 221 | Definition fully_react (cs cs' : list A) : Prop := 222 | react_steps cs cs' /\ inert cs'. 223 | 224 | Corollary react_steps_injective : 225 | forall cs cs1 cs2, 226 | fully_react cs cs1 -> 227 | fully_react cs cs2 -> 228 | cs1 = cs2. 229 | Proof. 230 | intros cs cs1 cs2 [Hcs1 Hinert1] [Hcs2 Hinert2]. 231 | pose proof (Confluent_react_step cs cs1 cs2 Hcs1 Hcs2) 232 | as [cs3 [Hcs13 Hcs23]]. 233 | destruct Hcs13. 234 | - destruct Hcs23. 235 | + reflexivity. 236 | + exfalso; eapply Hinert2; eauto. 237 | - exfalso; eapply Hinert1; eauto. 238 | Qed. 239 | 240 | (* Extra lemmas. *) 241 | 242 | Lemma react_rev_cong1 : 243 | forall cs cs', 244 | react_step cs cs' -> react_step (rev cs) (rev cs'). 245 | Proof. 246 | intros cs cs' Hcs. 247 | inversion Hcs. 248 | repeat (rewrite rev_app_distr; simpl). 249 | repeat (rewrite <- app_assoc); simpl. 250 | constructor. 251 | apply can_react_symmetric; auto. 252 | Qed. 253 | 254 | Lemma react_rev_cong : 255 | forall cs cs', 256 | react_step cs cs' <-> react_step (rev cs) (rev cs'). 257 | Proof. 258 | split; intros Hcs'; apply react_rev_cong1 in Hcs'; auto. 259 | do 2 rewrite rev_involutive in Hcs'; auto. 260 | Qed. 261 | 262 | Lemma inert_rev_cong1 : 263 | forall cs, inert cs -> inert (rev cs). 264 | Proof. 265 | intros cs Hcs cs' Hcs'. 266 | eapply Hcs. 267 | apply react_rev_cong. 268 | rewrite rev_involutive; eauto. 269 | Qed. 270 | 271 | Lemma inert_rev_cong : 272 | forall cs, inert cs <-> inert (rev cs). 273 | Proof. 274 | split; intro Hcs; apply inert_rev_cong1 in Hcs; auto. 275 | rewrite rev_involutive in Hcs; auto. 276 | Qed. 277 | 278 | Theorem fully_react_rev_cong1 : 279 | forall cs cs', 280 | fully_react (rev cs) (rev cs') -> 281 | fully_react cs cs'. 282 | Proof. 283 | intros cs cs' [Hcs Hinert]; split. 284 | - remember (rev cs) as rev_cs. 285 | remember (rev cs') as rev_cs'. 286 | gd (cs, cs'). 287 | induction Hcs; intros; subst. 288 | + rewrite <- (rev_involutive cs). 289 | rewrite <- (rev_involutive cs'). 290 | rewrite Heqrev_cs'. 291 | constructor. 292 | + apply react_rev_cong in H1. 293 | rewrite rev_involutive in H1. 294 | econstructor; eauto. 295 | eapply IHHcs; eauto. 296 | rewrite rev_involutive; auto. 297 | - intros cs''. 298 | rewrite react_rev_cong. 299 | auto. 300 | Qed. 301 | 302 | Theorem fully_react_rev_cong : 303 | forall cs cs', 304 | fully_react (rev cs) (rev cs') <-> 305 | fully_react cs cs'. 306 | Proof. 307 | split; intros; apply fully_react_rev_cong1; auto. 308 | do 2 rewrite rev_involutive; auto. 309 | Qed. 310 | 311 | Lemma inert_nil : inert []. 312 | Proof. 313 | intros cs' Hcs'. 314 | inversion Hcs'. 315 | destruct cs1 as [|? [|]]; try discriminate. 316 | Qed. 317 | 318 | Lemma inert_single a : inert [a]. 319 | Proof. 320 | intros cs' Hcs'. 321 | inversion Hcs'. 322 | destruct cs1 as [|? [|]]; try discriminate. 323 | Qed. 324 | 325 | Lemma inert_cons a c cs : 326 | ~ can_react a c -> inert (c :: cs) -> inert (a :: c :: cs). 327 | Proof. 328 | intros Hcanr Hinert cs' Hcs'. inversion Hcs'; clear Hcs'. 329 | destruct cs1 eqn:ecs1; simpl in *. 330 | - inversion H1; subst; auto. 331 | - eapply Hinert. 332 | inversion H1; subst; auto. 333 | Qed. 334 | 335 | Lemma inert_uncons a c cs : 336 | inert (a :: c :: cs) -> ~ can_react a c /\ inert (c :: cs). 337 | Proof. 338 | intros Hinert; split. 339 | - intro Hcanr. apply (Hinert cs), (RStep []); auto. 340 | - intros cs' Hcs'. 341 | apply (Hinert (a :: cs')), react_cons_congr1; auto. 342 | Qed. 343 | 344 | Lemma inert_unapp cs cs' : inert (cs ++ cs') -> inert cs /\ inert cs'. 345 | Proof. 346 | induction cs. 347 | - split; auto. apply inert_nil. 348 | - intros H'. destruct cs as [ | ? cs]. 349 | + destruct cs'. 350 | * split; auto. apply inert_nil. 351 | * split. 352 | -- apply inert_single. 353 | -- eapply inert_uncons; eauto. 354 | + apply inert_uncons in H' as [H1' H2']. 355 | apply IHcs in H2' as [H2' H3']. 356 | split; auto. 357 | apply inert_cons; auto. 358 | Qed. 359 | 360 | End react_generic. 361 | 362 | Global Arguments Reactive : clear implicits. 363 | Global Arguments GoodReactive : clear implicits. 364 | Global Arguments GoodReactive A {_}. 365 | 366 | Instance Reactive_int : Reactive int := 367 | fun x y => reactable x y = true. 368 | 369 | Instance GoodReactive_int : GoodReactive int. 370 | Admitted. 371 | 372 | Theorem react_correct : 373 | forall cs, fully_react cs (react cs). 374 | Proof. 375 | unfold react, rev_react. 376 | cut (forall cs stack, 377 | inert (rev stack) -> 378 | fully_react (rev cs ++ stack) (fold_left react_f cs stack)). 379 | { intros H cs. 380 | specialize (H cs []); rewrite app_nil_r in H. 381 | rewrite <- (rev_involutive cs) at 1. 382 | rewrite fully_react_rev_cong. 383 | apply H. 384 | intros cs' Hcs'. 385 | inversion Hcs'. 386 | destruct cs1; discriminate. 387 | } 388 | intros cs. 389 | induction cs; simpl. 390 | - repeat constructor. intros cs Hcs. 391 | eapply H. 392 | rewrite react_rev_cong in Hcs. 393 | eauto. 394 | - intros; rewrite <- app_assoc. 395 | destruct stack as [|c' stack'] eqn:estack; simpl. 396 | + apply IHcs; simpl; clear. 397 | apply inert_single. 398 | + destruct reactable eqn:e_reactable. 399 | simpl in H. apply inert_unapp in H as [H _]. 400 | apply IHcs in H. 401 | * split. 402 | { econstructor. 403 | - constructor; auto. 404 | - apply H. 405 | } 406 | { apply H. } 407 | * apply IHcs. 408 | rewrite <- inert_rev_cong in *. 409 | apply inert_cons; auto. 410 | apply Bool.not_true_iff_false; auto. 411 | Qed. 412 | 413 | End spec. 414 | 415 | Section example. 416 | Definition A := 0. Definition a := 1. 417 | Definition B := 2. Definition b := 3. 418 | Definition C := 4. Definition c := 5. 419 | Instance Reactive_nat : Reactive nat := 420 | fun (x y : nat) => S x = y \/ x = S y. 421 | Fixpoint react_list (css : list (list nat)) : Prop := 422 | match css with 423 | | cs :: (cs' :: _) as css => 424 | react_step cs cs' /\ 425 | react_list css 426 | | _ => True 427 | end. 428 | Example react_ex : 429 | react_list 430 | [[A;c;C;a;C;B;A;c;C]; 431 | [A;a;C;B;A;c;C]; 432 | [C;B;A;c;C]; 433 | [C;B;A]]. 434 | Proof. 435 | repeat constructor. 436 | - eapply (RStep [A]). right;auto. 437 | - eapply (RStep []). left;auto. 438 | - eapply (RStep [_; _; _]). right; auto. 439 | Qed. 440 | End example. 441 | -------------------------------------------------------------------------------- /sol/day03_1.v: -------------------------------------------------------------------------------- 1 | (* Two solutions are implemented, with n = nb of rectangles 2 | (i.e., input size): 3 | - [day03_1_simple.ml], naive O(grid_size * n) 4 | - [day03_1.ml], O(n log(n)) 5 | *) 6 | 7 | Set Warnings "-extraction-opaque-accessed". 8 | 9 | From Coq Require Import 10 | List Arith NArith ZArith Ascii String 11 | OrderedTypeEx FSetAVL FMapAVL 12 | extraction.ExtrOcamlIntConv 13 | Lia. 14 | Import ListNotations. 15 | 16 | From SimpleIO Require SimpleIO. 17 | 18 | From ExtLib Require Import 19 | Structures.Monads. 20 | Import MonadNotation. 21 | Local Open Scope monad. 22 | 23 | From advent Require Import lib. 24 | 25 | (* Sets indexed by natural numbers. *) 26 | Module NatSet := FSetAVL.Make Nat_as_OT. 27 | 28 | (* Maps indexed by (binary) natural numbers. *) 29 | Module NMap := FMapAVL.Make N_as_OT. 30 | 31 | 32 | (* A naive solution. *) 33 | 34 | Variant rectangle : Type := 35 | | Rectangle (id : N) (left top width height : N) 36 | . 37 | 38 | Definition matrix := list (list nat). 39 | 40 | Definition rectangle_matrix (r : rectangle) : matrix := 41 | let '(Rectangle _ l t w h) := r in 42 | let row := N.iter l (cons 0) (N.iter w (cons 1) []) in 43 | N.iter t (cons []) (N.iter h (cons row) []). 44 | 45 | Fixpoint union {A : Type} 46 | (merge : A -> A -> A) (xs ys : list A) : list A := 47 | match xs, ys with 48 | | [], _ => ys 49 | | _, [] => xs 50 | | x :: xs, y :: ys => merge x y :: union merge xs ys 51 | end. 52 | 53 | Definition union1 : list nat -> list nat -> list nat := union plus. 54 | Definition union2 : matrix -> matrix -> matrix := union union1. 55 | 56 | Definition union_rectangles (rs : list rectangle) : matrix := 57 | fold_left (fun x r => union2 x (rectangle_matrix r)) rs []. 58 | 59 | Definition count_overlaps (x : matrix) : N := 60 | fold_left (fun p row => 61 | fold_left (fun p c => if 2 <=? c then (1 + p)%N else p) row p) 62 | x 0%N. 63 | 64 | (* Then [fun rs : rectangle => count_overlaps (union_rectangles rs)] 65 | computes the expected answer: the area of the plane covered by 66 | at least two rectangles in [rs]. *) 67 | 68 | 69 | (* A less naive solution. *) 70 | 71 | (* First, there's a neat scanning algorithm bounding the complexity 72 | by O(matrix_sz + n_rectangles) (with an extra log factor because 73 | we don't have O(1) random access), but we can also avoid a boring 74 | array iteration by only traversing rectangle corners. 75 | We get O(n log(n)) where n = n_rectangles. 76 | *) 77 | 78 | (* The high-level idea is thus: put 1 and -1 on/near the corners of 79 | a rectangle (i,j)×(a,b) as follows (the top row and leftmost 80 | column are coordinate axes, every other entry in the matrix is 0): 81 | 82 | i j j+1 83 | 84 | a 1 0 ... 0 -1 85 | 0 0 86 | . . 87 | . . 88 | b 0 0 89 | b+1 -1 0 ... 0 1 90 | 91 | then, 1. do a scan (cumulative sum) for each column, 92 | 2. do a scan for each row of the matrix resulting from 1, 93 | that fills the rectangle with 1, and sets the rest of the 94 | matrix to 0. 95 | 96 | i j j+1 97 | a 1 1 ... 1 0 98 | . . . 99 | . . . 100 | . . . 101 | b 1 1 ... 1 0 102 | b+1 0 ... 0 0 103 | 104 | this formula is linear, so that if you add multiple rectangles 105 | in the same matrix, the scan will give you a matrix where each 106 | entry says how many rectangles contain it. 107 | *) 108 | 109 | (* A sparse infinite matrix as a map [N -> N -> Z] ([N * N -> Z]), 110 | where all unbound keys are mapped to 0. *) 111 | Definition smatrix := NMap.t (NMap.t Z). 112 | 113 | (* Modify the entry at row [i], column [j]. *) 114 | Definition set_point (f : Z -> Z) (i j : N) (x : smatrix) : smatrix := 115 | let '(row, u') := 116 | match NMap.find i x with 117 | | None => (NMap.empty _, f 0%Z) 118 | | Some row => (row, match NMap.find j row with 119 | | None => f 0%Z 120 | | Some u => f u 121 | end) 122 | end in 123 | NMap.add i (NMap.add j u' row) x. 124 | 125 | (* Print a rectangle into the matrix. *) 126 | Definition add_rectangle (r : rectangle) (x : smatrix) : smatrix := 127 | let '(Rectangle _ l t w h) := r in 128 | set_point Z.succ t l ( 129 | set_point Z.pred t (l + w) ( 130 | set_point Z.pred (t + h) l ( 131 | set_point Z.succ (t + h) (l + w) x))). 132 | 133 | Definition sunion_rectangles (rs : list rectangle) : smatrix := 134 | fold_left (fun x r => add_rectangle r x) rs (NMap.empty _). 135 | 136 | Definition Row : Type := list (N * Z). 137 | 138 | Notation conspair' i z t := 139 | (if (z =? 0)%Z then 140 | t 141 | else 142 | (i, z%Z) :: t). 143 | 144 | Fixpoint add_rows (r1 r2 : list (N * Z)) : list (N * Z) := 145 | match r1 with 146 | | [] => r2 147 | | (i1, z1) :: tl_r1 => 148 | let fix add_row2 r2 := 149 | match r2 with 150 | | [] => r1 151 | | (i2, z2) :: tl_r2 => 152 | match N_as_OT.compare i1 i2 with 153 | | OrderedType.LT _ => 154 | conspair' i1 z1 (add_rows tl_r1 r2) 155 | | OrderedType.EQ _ => 156 | let z' := (z1 + z2)%Z in 157 | conspair' i1 z' (add_rows tl_r1 tl_r2) 158 | | OrderedType.GT _ => 159 | conspair' i2 z2 (add_row2 tl_r2) 160 | end 161 | end in 162 | add_row2 r2 163 | end. 164 | 165 | (* Scan a row, looking for areas covered by overlapping rectangles 166 | (z0 > 2). *) 167 | Fixpoint scan_row_aux 168 | (n : N) (i0 : N) (z0 : Z) (r : list (N * Z)) : N := 169 | match r with 170 | | [] => n 171 | | (i, z) :: r => 172 | let n' := if (2 <=? z0)%Z then (n + i - i0)%N else n in 173 | scan_row_aux n' i (z0 + z)%Z r 174 | end. 175 | 176 | Definition scan_row : list (N * Z) -> N := scan_row_aux 0 0 0. 177 | 178 | (* 0 5 0 179 | 0 0 2 0 0-1 0 0 0 0 1-2 (row) 180 | 0 0 2 2 2 1 1 1 1 1 2 0 (scanned row) (four 2's) 181 | *) 182 | 183 | Example scan_row_ex : 184 | scan_row [(2%N, 2%Z); (5%N, (-1)%Z); (10%N, 1%Z); (11%N, (-2)%Z)] 185 | = 4%N. 186 | Proof. reflexivity. Qed. 187 | 188 | Fixpoint scan_aux 189 | (n : N) (r0 : list (N * Z)) 190 | (rs : list (N * list (N * Z))) : N := 191 | match rs with 192 | | (i1, r1) :: ((i2, _) :: _) as rs => 193 | let r1' := add_rows r0 r1 in 194 | scan_aux (n + (i2 - i1) * scan_row r1') r1' rs 195 | | [_] | [] => n (* The last row should be empty *) 196 | end. 197 | 198 | Definition scan : list (N * list (N * Z)) -> N := scan_aux 0 []. 199 | 200 | Definition count_overlaps2 (rs : list rectangle) : N := 201 | scan (NMap.elements 202 | (NMap.map (@NMap.elements _) 203 | (sunion_rectangles rs))). 204 | 205 | (* For debugging. *) 206 | Section debug. 207 | 208 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} 209 | `{MonadI rectangle m} 210 | `{MonadO (list ascii) m}. 211 | 212 | Definition print_matrix (x : matrix) : m unit := 213 | for' x (fun row => 214 | print (map (fun n => 215 | match n with 216 | | 0 => "0" 217 | | 1 => "1" 218 | | 2 => "2" 219 | | 3 => "3" 220 | | 4 => "4" 221 | | 5 => "5" 222 | | _ => "#" 223 | end%char) row)). 224 | 225 | Definition show_matrix (w h : nat) : m unit := 226 | rs <- read_all;; 227 | let x := fold_left 228 | (fun m r => union2 m (rectangle_matrix r)) rs [] in 229 | print_matrix (map (firstn w) (firstn h x)). 230 | 231 | End debug. 232 | 233 | Section main. 234 | 235 | Context {m : Type -> Type} `{Monad m} `{MonadFix m} 236 | `{MonadI rectangle m} 237 | `{MonadO N m}. 238 | 239 | Definition main1 : m unit := 240 | rs <- read_all;; 241 | print (count_overlaps (union_rectangles rs)). 242 | 243 | Definition main2 : m unit := 244 | rs <- read_all;; 245 | print (count_overlaps2 rs). 246 | 247 | End main. 248 | 249 | Module io. 250 | 251 | Import SimpleIO. 252 | Import IO.Notations. 253 | 254 | Parameter parse_rectangle : ocaml_string -> int * int * int * int * int. 255 | Extract Constant parse_rectangle => 256 | "fun s -> Scanf.sscanf s ""#%d @ %d,%d: %dx%d"" 257 | (fun i l t w h -> (((i, l), t), w), h)". 258 | 259 | Instance MonadI_rectangle_IO : MonadI rectangle IO := { 260 | read := catch_eof ( 261 | s <- read_line';; 262 | let '(i, l, t, w, h) := parse_rectangle s in 263 | ret (Rectangle (n_of_int i) (n_of_int l) (n_of_int t) (n_of_int w) (n_of_int h))) 264 | }. 265 | 266 | End io. 267 | 268 | Import SimpleIO. 269 | 270 | (* DEBUG *) 271 | (* 272 | Definition show_matrix_exec : io_unit := unsafe_run (show_matrix 0 0). 273 | Extraction "day03_1_show_matrix.ml" show_matrix_exec. 274 | *) 275 | 276 | Definition exec1 : io_unit := IO.unsafe_run main1. 277 | Extraction "day03_1_basic.ml" exec1. 278 | 279 | Definition exec2 : io_unit := IO.unsafe_run main2. 280 | Extraction "day03_1.ml" exec2. 281 | 282 | (* We first verify the naive solution. *) 283 | 284 | (* Points are given by their coordinates; shapes are sets of points. *) 285 | Definition point : Type := nat * nat. 286 | Definition shape : Type := point -> Prop. 287 | Definition eq_shape (s1 s2 : shape) : Prop := 288 | forall p, s1 p <-> s2 p. 289 | 290 | (* And of course, rectangles are shapes. *) 291 | Definition rectangle_shape (r : rectangle) : shape := 292 | let '(Rectangle _ l t w h) := r in 293 | fun p => N.to_nat l <= fst p < N.to_nat l + N.to_nat w /\ 294 | N.to_nat t <= snd p < N.to_nat t + N.to_nat h. 295 | 296 | Lemma sumbool_right_de_morgan P Q R : 297 | { P } + { ~ Q \/ ~ R } -> { P } + { ~ (Q /\ R) }. 298 | Proof. firstorder. Qed. 299 | 300 | Definition rectangle_shape_dec (r : rectangle) (p : point) : 301 | {rectangle_shape r p} + {~ rectangle_shape r p}. 302 | Proof. 303 | destruct r; simpl. 304 | repeat (apply sumbool_right_de_morgan; apply Sumbool.sumbool_and); 305 | apply le_dec. 306 | Qed. 307 | 308 | Definition sum (xs : list nat) : nat := 309 | fold_left plus xs 0. 310 | 311 | (* This function counts the number of rectangles in a list [rs] 312 | covering a given point [p]. *) 313 | Definition count_covering_rectangles 314 | (rs : list rectangle) (p : point) : nat := 315 | sum (map (fun r => if rectangle_shape_dec r p then 1 else 0) rs). 316 | 317 | Definition matrix_ix (x : matrix) (p : point) : nat := 318 | nth (fst p) (nth (snd p) x []) 0. 319 | 320 | (* Matrices produced by [rectangle_points] define shapes too. *) 321 | Definition matrix_shape (x : matrix) : shape := 322 | fun p => 0 < matrix_ix x p. 323 | 324 | Ltac simpl_length := 325 | repeat rewrite repeat_length in *. 326 | 327 | Ltac split_nth := 328 | match goal with 329 | | [ |- context [nth ?x (app ?t1 ?t2)] ] => 330 | let Hx := fresh "Hx" in 331 | destruct (Nat.lt_ge_cases x (List.length t1)) as [Hx | Hx]; 332 | [ rewrite app_nth1 with (n := x) 333 | | rewrite app_nth2 with (n := x) 334 | ] 335 | | [ |- context [ nth ?m (repeat ?a ?n) ?b ]] => 336 | let Hl := fresh "Hl" in 337 | destruct (Nat.lt_ge_cases m n) as [Hl | Hl]; 338 | [ rewrite (repeat_nth1 m n a b) 339 | | rewrite (repeat_nth2 m n a b) 340 | ] 341 | | [ |- context [ nth ?m [] ?b ]] => 342 | rewrite nth_nil 343 | end; auto; simpl_length. 344 | 345 | Lemma rectangle_shape_matrix1 (r : rectangle) (p : point) : 346 | rectangle_shape r p -> matrix_ix (rectangle_matrix r) p = 1. 347 | Proof. 348 | destruct r, p as [i j]. 349 | unfold matrix_ix; simpl. 350 | repeat rewrite N2Nat.inj_iter. 351 | repeat rewrite iter_cons. 352 | intros [[Hleft Hwidth] [Htop Hheight]]. 353 | repeat 354 | ((rewrite repeat_nth1 + rewrite app_nth2 + rewrite app_nth1); 355 | simpl_length; [|lia]). 356 | lia. 357 | Qed. 358 | 359 | Lemma rectangle_shape_matrix2 (r : rectangle) (p : point) : 360 | ~rectangle_shape r p -> matrix_ix (rectangle_matrix r) p = 0. 361 | Proof. 362 | destruct r, p as [i j]. 363 | unfold matrix_ix; simpl. 364 | repeat rewrite N2Nat.inj_iter. 365 | repeat rewrite iter_cons. 366 | intros H. 367 | repeat split_nth. 368 | exfalso; apply H; lia. 369 | Qed. 370 | 371 | (* [matrix_ix] is a monoid homomorphism, between [union2] and [plus]. 372 | *) 373 | 374 | Lemma matrix_ix_hom x1 x2 p : 375 | matrix_ix (union2 x1 x2) p = matrix_ix x1 p + matrix_ix x2 p. 376 | Proof. 377 | destruct p as [i j]. 378 | revert x1; revert x2. 379 | revert i. unfold matrix_ix. 380 | simpl. 381 | induction j. 382 | - destruct x1 as [ | t1 x1 ], x2 as [ | t2 x2]; 383 | repeat rewrite nth_nil; simpl; auto. 384 | destruct i; auto. 385 | clear. revert t2; revert t1. 386 | induction i. 387 | + destruct t1, t2; simpl; auto. 388 | + destruct t1, t2; simpl; auto. 389 | - destruct x1, x2; repeat rewrite nth_nil; simpl; auto. 390 | destruct i; auto. 391 | Qed. 392 | 393 | Theorem union_rectangles_count rs p : 394 | matrix_ix (union_rectangles rs) p = count_covering_rectangles rs p. 395 | Proof. 396 | unfold union_rectangles. 397 | pose proof 398 | (fold_left_hom 399 | (fun x r => union2 x (rectangle_matrix r)) 400 | (fun n r => n + if rectangle_shape_dec r p then 1 else 0) 401 | (fun x => matrix_ix x p)). 402 | simpl in H; rewrite H; clear H. 403 | { rewrite fold_left_map. unfold count_covering_rectangles. 404 | unfold matrix_ix; repeat rewrite nth_nil; auto. 405 | } 406 | { intros; rewrite matrix_ix_hom. 407 | destruct rectangle_shape_dec. 408 | - rewrite rectangle_shape_matrix1; auto. 409 | - rewrite rectangle_shape_matrix2; auto. 410 | } 411 | Qed. 412 | --------------------------------------------------------------------------------