├── .dir-locals.el ├── .gitignore ├── Makefile ├── README.md ├── arith ├── add1.v ├── add1_gen.rkt ├── mult.v ├── mult_gen.rkt ├── plus.v ├── plus_cin_gen.rkt ├── plus_gen.rkt ├── sub1.v ├── sub1_gen.rkt ├── sub1_linear.v └── sub1_linear_loop_gen.rkt ├── common ├── array.v ├── big_oh.v ├── braun.v ├── finite_sums.v ├── index.v ├── le_util.v ├── list_util.v ├── log.v ├── pow.v ├── same_structure.v ├── sequence.v └── util.v ├── copy ├── copy2_gen.rkt ├── copy_fib_log.v ├── copy_fib_log_gen.rkt ├── copy_linear.v ├── copy_linear_gen.rkt ├── copy_log.v ├── copy_log_gen.rkt ├── copy_log_sq.v └── copy_log_sq_gen.rkt ├── extract ├── extract.ml └── extract.v ├── fib ├── fib.v ├── fib_iter.v ├── fib_iter_gen.rkt ├── fib_iter_loop_gen.rkt ├── fib_rec.v └── fib_rec_gen.rkt ├── fold ├── fold.v └── fold_gen.rkt ├── insert ├── insert_log.v ├── insert_log_gen.rkt └── insert_nogen.v ├── line-counts.txt ├── make_array ├── build.v ├── build_gen.rkt ├── drop_gen.rkt ├── foldr_build_gen.rkt ├── make_array_linear.v ├── make_array_linear_gen.rkt ├── make_array_nlogn1.v ├── make_array_nlogn1_fold.v ├── make_array_nlogn1_gen.rkt ├── make_array_nlogn2.v ├── make_array_nlogn2_gen.rkt ├── pad_drop_gen.rkt ├── rows.v ├── rows1_gen.rkt ├── rows_gen.rkt ├── split_gen.rkt ├── take_drop_split.v ├── take_gen.rkt ├── unravel_gen.rkt └── zip_with_3_bt_node_gen.rkt ├── monad ├── laws.v ├── monad.v └── smonad.v ├── paper ├── .gitignore ├── TODO.org ├── binds.v ├── case-study.scrbl ├── cite.rkt ├── extract-insert.scrbl ├── extract.rkt ├── insert.scrbl ├── line-counts.rkt ├── monad.scrbl ├── other-prims.scrbl ├── paper.pdf ├── paper.scrbl ├── prims-overview.txt ├── prims.scrbl ├── related-work.scrbl ├── running-time.scrbl └── util.rkt ├── rbtrees ├── bst_search_gen.rkt ├── match-star.rkt ├── rbt_balance_gen.rkt ├── rbt_blacken_gen.rkt ├── rbt_insert.v ├── rbt_insert_gen.rkt ├── rbt_insert_inner_gen.rkt ├── rbt_search.v └── rbtree.v ├── rkt ├── README.txt ├── braun.rkt ├── copy_linear_sub1.rkt ├── diff-sub-div-plot.rkt ├── diff_sub1.rkt ├── fib-facts.rkt ├── fib-rt.rkt ├── log.rkt ├── make-array-test.rkt ├── make-array.rkt ├── mergesort-strange-fact.rkt ├── pict.rkt ├── size-scratch.rkt ├── sub1-ex.rkt ├── sub1-plot.rkt ├── sub1_div2.rkt ├── sub1_linear.rkt ├── sub1s.org └── tmonad │ ├── coq.rkt │ ├── emit.rkt │ ├── info.rkt │ ├── main.rkt │ ├── overly-specific.rkt │ └── private │ └── the-lang.rkt ├── size ├── diff_gen.rkt ├── size_linear.v ├── size_linear_bin.v ├── size_linear_bin_gen.rkt ├── size_linear_gen.rkt ├── size_log_sq.v └── size_log_sq_gen.rkt ├── sort ├── clength_gen.rkt ├── insert_gen.rkt ├── isort.v ├── isort_gen.rkt ├── merge_gen.rkt ├── mergesort.v ├── mergesort_gen.rkt ├── mergesortc_gen.rkt ├── sorting.v └── split2_gen.rkt ├── to_list ├── cinterleave_gen.rkt ├── to_list_naive.v └── to_list_naive_gen.rkt └── zippers ├── from_zip_gen.rkt ├── insert_at_gen.rkt ├── minsert_at_gen.rkt ├── minsertz_at_gen.rkt ├── to_zip_gen.rkt ├── zip.v ├── zip_insert_gen.rkt ├── zip_left_gen.rkt ├── zip_leftn_gen.rkt ├── zip_minsert_gen.rkt ├── zip_right_gen.rkt └── zip_rightn_gen.rkt /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ((coq-mode . ((coq-prog-args . 2 | ("-emacs" "-R" "/Users/jay/Dev/dist/rfindler/395-2013" "Braun"))))) 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *_gen.v 2 | paper/paper-appendix.pdf 3 | *~ 4 | *.vo 5 | *.glob 6 | *.cmi 7 | *.cmo 8 | *.mli 9 | *.d 10 | *.aux 11 | Makefile.coq 12 | /*.ml 13 | *.bin 14 | compiled/ 15 | extract/extract.ml 16 | extract/extract 17 | extract/sextract.ml 18 | extract/sextract 19 | /paper-final.zip 20 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | GEN := $(shell find . -type f -name '*_gen.rkt' ) 2 | VS := $(shell find . -type f -name '*v' | grep -v _gen.v) 3 | VERSIONS := tmonad 4 | GEN_DEPS := rkt/tmonad/emit.rkt rkt/tmonad/main.rkt rkt/tmonad/coq.rkt 5 | 6 | all: code admit paper/paper.pdf 7 | 8 | admit: 9 | @echo "" 10 | @echo "" 11 | @ ! grep -i admit $(VS) 12 | 13 | paper: line-counts.txt paper/paper.pdf 14 | 15 | line-counts.txt: paper/line-counts.rkt 16 | racket -t $^ > $@ 17 | 18 | supp: DNE 19 | @echo 20 | @echo did you make clean first? 21 | @echo 22 | tar czf supp.tar.gz `ls | grep -v paper` 23 | du -s -h supp.tar.gz 24 | 25 | DNE: 26 | 27 | code: coq extract/extract 28 | 29 | # this might work for the flops version; it doesn't 30 | # work the version currently in paper/ 31 | #paper/paper-appendix.pdf: paper/paper.pdf 32 | # (cd paper; rm paper.pdf && env BUILD-WITH-APPENDIX=true scribble --pdf paper.scrbl && mv paper.pdf paper-appendix.pdf) 33 | 34 | paper/paper.pdf: line-counts.txt paper/paper.scrbl paper/util.rkt paper/running-time.scrbl paper/prims.scrbl paper/insert.scrbl paper/monad.scrbl paper/case-study.scrbl paper/related-work.scrbl */*.v code 35 | (cd paper; raco make -v paper.scrbl && scribble --pdf paper.scrbl; cd ..) 36 | 37 | paper/paper.tex: paper/paper.pdf 38 | (cd paper; scribble --latex paper.scrbl) 39 | 40 | paper-final.zip: paper/paper.tex 41 | zip $@ $^ 42 | 43 | .PHONY: coq clean clean-ml tmonad-gen 44 | 45 | clean-ml: 46 | rm -f $(VERSIONS:%=%/extract.vo) 47 | 48 | coq: Makefile.coq 49 | mkdir -p ml 50 | $(MAKE) -f Makefile.coq 51 | 52 | extract/extract.ml: extract/extract.vo 53 | coqc -q -R . Braun extract/extract.v 54 | echo "open Big_int;;" > extract/extract.ml 55 | cat post_extract.ml >> extract/extract.ml 56 | rm post_extract.ml 57 | 58 | extract/extract: extract/extract.ml 59 | ocamlc -I ml -o $@ nums.cma $^ 60 | 61 | tmonad-gen: $(GEN:%.rkt=%.v) 62 | 63 | %_gen.v: %_gen.rkt $(GEN_DEPS) 64 | raco make $< 65 | racket $< > $@ 66 | 67 | Makefile.coq: tmonad-gen Makefile $(VS) 68 | coq_makefile -R . Braun $(VS) -o Makefile.coq 69 | 70 | %.vo : coq 71 | @: 72 | 73 | clean: Makefile.coq 74 | $(MAKE) -f Makefile.coq clean 75 | rm -f paper/paper.pdf 76 | rm -f supp.tar.gz 77 | rm -f extract/extract.ml extract/a.out extract/extract.mli 78 | find . -type d -name compiled -exec rm -rf '{}' + 79 | find . \( -name '*.vo' -o -name '*.d' -o -name '*.glob' -o -name '*.cmi' -o -name '*.cmo' -o -name '*_gen.v' \) -exec rm -f {} \; 80 | -------------------------------------------------------------------------------- /arith/add1.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.log. 2 | Require Import Braun.common.util Braun.common.big_oh Braun.common.le_util. 3 | Require Import Arith Arith.Even Arith.Div2. 4 | Require Import Coq.Program.Wf Arith.Even Arith.Div2 Arith Init.Wf Omega. 5 | 6 | Include WfExtensionality. 7 | 8 | Program Fixpoint add1_time (n:nat) {measure n} := 9 | match n with 10 | | 0 => 1 11 | | S _ => if (even_odd_dec n) 12 | then 1 13 | else (add1_time (div2 n)) + 1 14 | end. 15 | 16 | Lemma add1_time_0 : add1_time 0 = 1. 17 | Proof. 18 | unfold_sub add1_time (add1_time 0); auto. 19 | Qed. 20 | 21 | Lemma add1_time_S : forall n, 1 <= add1_time (S n). 22 | Proof. 23 | intros n. 24 | apply (well_founded_ind 25 | lt_wf 26 | (fun n => 27 | 1 <= add1_time n)). 28 | intros. 29 | destruct x. 30 | rewrite add1_time_0;auto. 31 | unfold_sub add1_time (add1_time (S x)). 32 | dispatch_if EW' EW';auto. 33 | fold_sub add1_time. 34 | destruct x; auto. 35 | omega. 36 | Qed. 37 | 38 | Definition add1_result (n:nat) (res:nat) (c:nat) := 39 | n+1 = res /\ c = add1_time n. 40 | Hint Unfold add1_result. 41 | 42 | Load "add1_gen.v". 43 | 44 | Next Obligation. 45 | Proof. 46 | split;auto. 47 | unfold_sub add1_time (add1_time (S wildcard')). 48 | fold_sub add1_time. 49 | dispatch_if EW EW'; intuition. 50 | assert False; intuition. 51 | apply (not_even_and_odd (S wildcard')); auto. 52 | Qed. 53 | 54 | Next Obligation. 55 | Proof. 56 | clear H2 am add1. 57 | rename H into EW. 58 | rename H1 into SR. 59 | 60 | destruct SR; subst sd2 an. 61 | 62 | split. 63 | replace (div2 (S wildcard') + 1 + (div2 (S wildcard') + 1)) 64 | with (S (div2 (S wildcard') + div2 (S wildcard')) + 1);[|omega]. 65 | replace (div2 (S wildcard') + div2 (S wildcard')) 66 | with (double (div2 (S wildcard')));[|unfold double;auto]. 67 | rewrite <- odd_double; auto. 68 | 69 | unfold_sub add1_time (add1_time (S wildcard')). 70 | fold_sub add1_time. 71 | dispatch_if EW' EW''; intuition. 72 | assert False; intuition. 73 | apply (not_even_and_odd (S wildcard')); auto. 74 | Qed. 75 | 76 | Program Fixpoint add1_time2 (n:nat) {measure n} := 77 | match n with 78 | | 0 => 0 79 | | S _ => if (even_odd_dec n) 80 | then 1 81 | else (add1_time2 (div2 n)) + 1 82 | end. 83 | 84 | Lemma add1_time_Sn : forall n, 85 | add1_time (S n) <= (add1_time (div2 (S n))) + 1. 86 | Proof. 87 | intros. 88 | unfold_sub add1_time (add1_time (S n)). 89 | fold_sub add1_time. 90 | dispatch_if EW EW. 91 | omega. 92 | destruct n; auto. 93 | Qed. 94 | 95 | Lemma add1_time12 : big_oh add1_time add1_time2. 96 | Proof. 97 | exists 1. 98 | exists 14. 99 | intros n LE. 100 | destruct n; intuition. 101 | clear LE. 102 | apply (well_founded_induction 103 | lt_wf 104 | (fun n => add1_time (S n) <= 14 * add1_time2 (S n))). 105 | clear n; intros n IND. 106 | unfold_sub add1_time (add1_time (S n)); fold_sub add1_time. 107 | unfold_sub add1_time2 (add1_time2 (S n)); fold add1_time2. 108 | dispatch_if COND1 COND1'; try omega. 109 | destruct n. 110 | simpl; omega. 111 | rewrite mult_plus_distr_l. 112 | apply plus_le_compat;[|omega]. 113 | apply IND; auto. 114 | Qed. 115 | 116 | Theorem add1_log : big_oh add1_time cl_log. 117 | Proof. 118 | apply (big_oh_trans add1_time add1_time2). 119 | apply add1_time12. 120 | 121 | exists 0. 122 | exists 1. 123 | intros n _. 124 | rewrite mult_1_l. 125 | apply (well_founded_induction 126 | lt_wf 127 | (fun n => add1_time2 n <= cl_log n)). 128 | clear n; intros n IND. 129 | destruct n. 130 | unfold_sub add1_time2 (add1_time2 0). 131 | omega. 132 | 133 | unfold_sub add1_time2 (add1_time2 (S n)). 134 | fold add1_time2. 135 | 136 | dispatch_if COND1 COND1'. 137 | rewrite <- fl_log_cl_log_relationship. 138 | apply le_n_S. 139 | omega. 140 | 141 | destruct n. 142 | simpl. 143 | rewrite cl_log_div2'. 144 | apply le_n_S. 145 | omega. 146 | 147 | apply (le_trans (add1_time2 (S (div2 n)) + 1) 148 | (cl_log (S (div2 n)) + 1)). 149 | apply plus_le_compat;auto. 150 | apply IND. 151 | apply lt_n_S. 152 | auto. 153 | 154 | replace (cl_log (S (S n))) with (S (cl_log (div2 (S (S n)))));[|rewrite cl_log_div2';auto]. 155 | simpl div2. 156 | omega. 157 | Qed. 158 | 159 | Lemma cl_log_bnd_add1_time : forall n, 160 | 1 <= n -> 161 | add1_time n <= 2 * cl_log n. 162 | Proof. 163 | intros. 164 | apply le_trans with (2*add1_time2 n). 165 | destruct n ; intuition. 166 | apply (well_founded_induction 167 | lt_wf 168 | (fun n => add1_time (S n) <= 2 * add1_time2 (S n))). 169 | intros. 170 | unfold_sub add1_time (add1_time (S x)); fold_sub add1_time. 171 | unfold_sub add1_time2 (add1_time2 (S x)); fold add1_time2. 172 | dispatch_if COND1 COND1'; try omega. 173 | destruct x. 174 | simpl; omega. 175 | rewrite mult_plus_distr_l. 176 | apply plus_le_compat;[|omega]. 177 | apply H0; auto. 178 | apply mult_le_compat_l. 179 | apply (well_founded_induction 180 | lt_wf 181 | (fun n => add1_time2 n <= cl_log n)). 182 | intros. 183 | destruct x. 184 | unfold_sub add1_time2 (add1_time2 0). 185 | omega. 186 | 187 | unfold_sub add1_time2 (add1_time2 (S x)). 188 | fold add1_time2. 189 | 190 | dispatch_if COND1 COND1'. 191 | rewrite <- fl_log_cl_log_relationship. 192 | apply le_n_S. 193 | omega. 194 | 195 | destruct x. 196 | simpl. 197 | rewrite cl_log_div2'. 198 | apply le_n_S. 199 | omega. 200 | 201 | apply (le_trans (add1_time2 (S (div2 x)) + 1) 202 | (cl_log (S (div2 x)) + 1)). 203 | apply plus_le_compat;auto. 204 | apply H0. 205 | apply lt_n_S. 206 | auto. 207 | 208 | replace (cl_log (S (S x))) with (S (cl_log (div2 (S (S x)))));[|rewrite cl_log_div2';auto]. 209 | simpl div2. 210 | omega. 211 | Qed. 212 | -------------------------------------------------------------------------------- /arith/add1_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | (provide add1) 3 | 4 | (Fixpoint 5 | add1 @n{nat} 6 | #:measure n 7 | #:returns @{nat} 8 | (match (n) 9 | [0 => (<== 1)] 10 | [(S _) 11 | => 12 | (if (even_odd_dec n) 13 | ;; this is not really addition; 14 | ;; it is and'ing the last bit (since 15 | ;; we know that the number is even), 16 | (<== (+ n 1)) 17 | (bind ((sd2 (add1 (div2 n)))) 18 | (<== (+ sd2 sd2))))])) 19 | -------------------------------------------------------------------------------- /arith/mult_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | (provide tmult) 3 | (require "plus_gen.rkt") 4 | 5 | (Fixpoint 6 | tmult @n{nat} @m{nat} 7 | #:measure n 8 | #:returns @{nat} 9 | (match (n) 10 | [0 => (<== 0)] 11 | [(S _) 12 | => 13 | (if (even_odd_dec n) 14 | (bind ([md2 (tmult (div2 n) m)]) 15 | (<== (double md2))) 16 | (bind ([md2 (tmult (div2 n) m)]) 17 | (bind ([res (tplus m (double md2))]) 18 | (<== res))))])) 19 | 20 | 21 | -------------------------------------------------------------------------------- /arith/plus_cin_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | 3 | (require "add1_gen.rkt") 4 | (provide plus_cin) 5 | 6 | (Fixpoint 7 | plus_cin @n{nat} @m{nat} @cin{bool} 8 | #:measure "(m+n)" 9 | #:returns @{nat} 10 | (match (n) 11 | [0 12 | => 13 | (match (m) 14 | [0 => (match (cin) 15 | [(true) => (<== 1)] 16 | [(false) => (<== 0)])] 17 | [(S m′) 18 | => 19 | (match (cin) 20 | [(true) 21 | => 22 | (bind ((res (add1 m))) 23 | (<== res))] 24 | [(false) => (<== m)])])] 25 | [(S n′) 26 | => 27 | (match (m) 28 | [0 29 | => 30 | (match (cin) 31 | [(true) 32 | => 33 | (bind ((res (add1 n))) 34 | (<== res))] 35 | [(false) => (<== n)])] 36 | [(S m′) 37 | => 38 | (bind ((ndiv2plusmdiv2plusX 39 | (plus_cin (div2 n) 40 | (div2 m) 41 | (orb (andb (negb (even_oddb n)) 42 | (negb (even_oddb m))) 43 | (andb cin 44 | (xorb (even_oddb n) 45 | (even_oddb m))))))) 46 | (match ((xorb (xorb (even_oddb n) 47 | (even_oddb m)) 48 | cin)) 49 | [(true) 50 | => 51 | (<== (double_plus1 ndiv2plusmdiv2plusX))] 52 | [(false) 53 | => 54 | (<== (double ndiv2plusmdiv2plusX))]))])])) 55 | 56 | -------------------------------------------------------------------------------- /arith/plus_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | 3 | (require "plus_cin_gen.rkt") 4 | 5 | (provide tplus) 6 | 7 | (Fixpoint 8 | tplus @n{nat} @m{nat} 9 | #:returns @{nat} 10 | (bind ((res (plus_cin n m false))) 11 | (<== res))) 12 | 13 | 14 | -------------------------------------------------------------------------------- /arith/sub1.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.log. 2 | Require Import Braun.common.util Braun.common.big_oh Braun.common.le_util. 3 | Require Import Arith Arith.Even Arith.Div2. 4 | Require Import Coq.Program.Wf Arith.Even Arith.Div2 Arith Init.Wf Omega. 5 | 6 | Include WfExtensionality. 7 | 8 | Program Fixpoint sub1_time (n:nat) {measure n} := 9 | match n with 10 | | 0 => 3 11 | | S _ => if (even_odd_dec n) 12 | then (sub1_time (div2 n)) + 12 13 | else 8 14 | end. 15 | 16 | Definition sub1_result (n:nat) (res:nat) (c:nat) := 17 | n-1 = res /\ c = sub1_time n. 18 | Hint Unfold sub1_result. 19 | 20 | Load "sub1_gen.v". 21 | 22 | Next Obligation. 23 | Proof. 24 | clear H2 am. 25 | rename H into EW. 26 | rename H1 into SR. 27 | 28 | destruct SR; subst sd2 an. 29 | 30 | split. 31 | 32 | rewrite (even_double (S wildcard')) at 1; auto. 33 | unfold double. 34 | remember (div2 (S wildcard')) as x. 35 | destruct x; try omega. 36 | 37 | destruct wildcard'. 38 | inversion EW. 39 | inversion H0. 40 | simpl in Heqx. 41 | inversion Heqx. 42 | 43 | unfold_sub sub1_time (sub1_time (S wildcard')). 44 | fold_sub sub1_time. 45 | dispatch_if EW' EW''; intuition. 46 | assert False; intuition. 47 | apply (not_even_and_odd (S wildcard')); auto. 48 | Qed. 49 | 50 | Next Obligation. 51 | Proof. 52 | split;auto. 53 | unfold_sub sub1_time (sub1_time (S wildcard')). 54 | fold_sub sub1_time. 55 | dispatch_if EW EW'; intuition. 56 | assert False; intuition. 57 | apply (not_even_and_odd (S wildcard')); auto. 58 | Qed. 59 | 60 | 61 | Program Fixpoint sub1_time2 (n:nat) {measure n} := 62 | match n with 63 | | 0 => 0 64 | | S _ => if (even_odd_dec n) 65 | then (sub1_time2 (div2 n)) + 1 66 | else 1 67 | end. 68 | 69 | Lemma sub1_time12 : big_oh sub1_time sub1_time2. 70 | Proof. 71 | exists 1. 72 | exists 50. 73 | intros n LE. 74 | destruct n; intuition. 75 | clear LE. 76 | apply (well_founded_induction 77 | lt_wf 78 | (fun n => sub1_time (S n) <= 50 * sub1_time2 (S n))). 79 | clear n; intros n IND. 80 | unfold_sub sub1_time (sub1_time (S n)); fold_sub sub1_time. 81 | unfold_sub sub1_time2 (sub1_time2 (S n)); fold sub1_time2. 82 | dispatch_if COND1 COND1'; try omega. 83 | destruct n. 84 | simpl; omega. 85 | rewrite mult_plus_distr_l. 86 | replace (50*1) with (38+12); [|omega]. 87 | rewrite plus_assoc. 88 | apply le_plus_left. 89 | apply le_add_right. 90 | apply IND; auto. 91 | Qed. 92 | 93 | Program Fixpoint sub1_time3 (n:nat) {measure n} := 94 | match n with 95 | | 0 => 0 96 | | S _ => (sub1_time3 (div2 n)) + 1 97 | end. 98 | 99 | Lemma sub1_time23 : big_oh sub1_time2 sub1_time3. 100 | Proof. 101 | exists 0. 102 | exists 1. 103 | intros. 104 | rewrite mult_1_l. 105 | apply (well_founded_ind 106 | lt_wf 107 | (fun n => sub1_time2 n <= sub1_time3 n)). 108 | clear. 109 | intros n IH. 110 | destruct n. 111 | compute. 112 | auto. 113 | assert (forall n, sub1_time3 (S n) = (sub1_time3 (div2 (S n)) + 1)). 114 | intros. 115 | unfold_sub sub1_time3 (sub1_time3 (S n0)). 116 | simpl. 117 | auto. 118 | rewrite H. 119 | unfold_sub sub1_time2 (sub1_time2 (S n)). 120 | fold_sub sub1_time2. 121 | dispatch_if EW EW. 122 | simpl. 123 | destruct n. 124 | simpl. 125 | auto. 126 | apply plus_le_compat;auto. 127 | apply IH. 128 | inversion EW. 129 | inversion H1. 130 | rewrite even_div2. 131 | apply lt_n_S. 132 | repeat auto. 133 | auto. 134 | omega. 135 | Qed. 136 | 137 | Lemma sub1_time3_is_cl_log : forall n, sub1_time3 n = cl_log n. 138 | Proof. 139 | intros. 140 | apply (well_founded_ind 141 | lt_wf 142 | (fun n => sub1_time3 n = cl_log n)). 143 | intros. 144 | destruct x. 145 | auto. 146 | unfold_sub sub1_time3 (sub1_time3 (S x)). 147 | unfold_sub cl_log (cl_log (S x)). 148 | destruct x. 149 | auto. 150 | replace ( S (cl_log (S (div2 x)))) with (cl_log (S (div2 x)) + 1);[|omega]. 151 | rewrite plus_comm at 1. 152 | replace (cl_log (S (div2 x)) + 1) with (1+cl_log (S (div2 x)));[|omega]. 153 | assert ( sub1_time3 (S (div2 x)) = cl_log (S (div2 x))). 154 | apply H. 155 | apply lt_n_S. 156 | auto. 157 | rewrite H0. 158 | auto. 159 | Qed. 160 | 161 | Lemma sub1_time3_O_cl_log : big_oh sub1_time3 cl_log. 162 | Proof. 163 | exists 0. 164 | exists 1. 165 | intros. 166 | rewrite mult_1_l. 167 | rewrite sub1_time3_is_cl_log. 168 | auto. 169 | Qed. 170 | 171 | Theorem sub1_log : big_oh sub1_time fl_log. 172 | Proof. 173 | eapply big_oh_trans. 174 | apply sub1_time12. 175 | eapply big_oh_trans. 176 | apply sub1_time23. 177 | eapply big_oh_trans. 178 | apply sub1_time3_O_cl_log. 179 | apply cl_log_O_fl_log. 180 | Qed. 181 | 182 | Lemma sub1_time_double : forall n, sub1_time (S(n+n)) = 8. 183 | Proof. 184 | intros. 185 | unfold_sub sub1_time (sub1_time (S (n+n))). 186 | fold sub1_time. 187 | destruct (even_odd_dec (S (n+n))); auto. 188 | assert False; [|intuition]. 189 | apply (not_even_and_odd (S (n+n))); auto. 190 | constructor. 191 | apply double_is_even. 192 | Qed. 193 | 194 | Lemma sub1_time_S_double : forall n, sub1_time (n+n) <= sub1_time n + 12. 195 | Proof. 196 | intros. 197 | destruct n. 198 | replace (0+0) with 0; omega. 199 | 200 | replace (S n + S n) with (S (S (n+n)));[|omega]. 201 | unfold_sub sub1_time (sub1_time (S (S (n+n)))). 202 | fold sub1_time. 203 | destruct (even_odd_dec (S (S (n+n)))). 204 | replace (n+n) with (2*n);[|omega]. 205 | rewrite div2_double. 206 | omega. 207 | assert False;[|intuition]. 208 | apply (not_even_and_odd (S (S (n+n)))); auto. 209 | constructor. 210 | constructor. 211 | apply double_is_even. 212 | Qed. 213 | -------------------------------------------------------------------------------- /arith/sub1_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide sub1) 3 | 4 | (Fixpoint 5 | sub1 @n{nat} 6 | #:measure n 7 | #:returns @{nat} 8 | (match (n) 9 | [0 => (<== 0)] 10 | [(S _) 11 | => 12 | (if (even_odd_dec n) 13 | (bind ((sd2 (sub1 (div2 n)))) 14 | (<== (+ sd2 sd2 1))) 15 | 16 | ;; this is not really subtraction; 17 | ;; it is masking the last bit (since 18 | ;; we know that the number is odd), 19 | ;; so it is okay to have something with 20 | ;; a constant cost here. 21 | (<== (- n 1)))])) 22 | -------------------------------------------------------------------------------- /arith/sub1_linear.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.log Braun.common.finite_sums. 2 | Require Import Braun.common.util Braun.common.big_oh Braun.common.le_util. 3 | Require Import Arith Arith.Even Arith.Div2. 4 | Require Import Coq.Program.Wf Arith.Even Arith.Div2 Arith Init.Wf. 5 | Require Import Braun.arith.sub1. 6 | 7 | Include WfExtensionality. 8 | 9 | Fixpoint sub1_linear_time n := 10 | match n with 11 | | 0 => 3 12 | | S n' => sub1_time n + sub1_linear_time n' + 7 13 | end. 14 | 15 | Definition sub1_linear_loop_result (n:nat) (res:nat) (c:nat) := 16 | c = sub1_linear_time n. 17 | Hint Unfold sub1_linear_loop_result. 18 | 19 | Load "sub1_linear_loop_gen.v". 20 | 21 | Next Obligation. 22 | Proof. 23 | rename H into SUB1R. 24 | destruct SUB1R. 25 | omega. 26 | Qed. 27 | 28 | Next Obligation. 29 | Proof. 30 | clear H2 am0 am H3 sub1_linear_loop. 31 | rename H1 into SUB1_RESULT. 32 | 33 | unfold sub1_linear_loop_result in *. 34 | destruct SUB1_RESULT. 35 | subst an an0 n'. 36 | unfold sub1_linear_time; fold sub1_linear_time. 37 | replace (S wildcard' - 1) with wildcard'; omega. 38 | Qed. 39 | 40 | Definition sub1_linear_time1 n := (sum 0 n (fun n => sub1_time n + 7)) - 7. 41 | 42 | Lemma sub1_linear_time01 : 43 | forall n, 44 | sub1_linear_time n = sub1_linear_time1 n. 45 | Proof. 46 | intros n. 47 | induction n. 48 | simpl. 49 | unfold sub1_linear_time1. 50 | simpl; auto. 51 | 52 | unfold sub1_linear_time. 53 | fold sub1_linear_time. 54 | rewrite IHn. 55 | unfold sub1_linear_time1. 56 | rewrite sum_S_j;[|omega]. 57 | 58 | assert (sum 0 n (fun n0 : nat => sub1_time n0 + 7) >= 7); try omega. 59 | 60 | induction n. 61 | simpl; omega. 62 | rewrite sum_S_j; omega. 63 | Qed. 64 | 65 | Definition sub1_linear_time2 n := (sum 0 n (fun n => sub1_time n + 7)). 66 | 67 | Lemma sub1_linear_time12 : big_oh sub1_linear_time1 sub1_linear_time2. 68 | Proof. 69 | unfold sub1_linear_time2. 70 | unfold sub1_linear_time1. 71 | exists 0. exists 1. 72 | intros n _. 73 | omega. 74 | Qed. 75 | 76 | Definition sub1_linear_time3 n := (sum 0 n (fun n => sub1_time n)) + 7*(n+1). 77 | 78 | Lemma sub1_linear_time23 : forall n, sub1_linear_time2 n = sub1_linear_time3 n. 79 | Proof. 80 | intros n. 81 | unfold sub1_linear_time2; unfold sub1_linear_time3. 82 | replace (fun n0 : nat => sub1_time n0 + 7) 83 | with (fplus sub1_time (const 7)); [| unfold fplus; unfold const; reflexivity]. 84 | rewrite <- sum_over_fns. 85 | unfold const. 86 | rewrite (sum_constant 0 n 7 n); [|omega]. 87 | intuition. 88 | Qed. 89 | 90 | Definition sub1_linear_time4 n := sum 0 n (fun n => sub1_time n). 91 | 92 | Lemma sub1_linear_time4_linear : big_oh sub1_linear_time4 (fun n => n). 93 | Proof. 94 | exists 1. 95 | exists 32. 96 | intros n LT. 97 | destruct n;[intuition|clear LT]. 98 | 99 | apply (well_founded_induction 100 | lt_wf 101 | (fun n => sub1_linear_time4 (S n) <= 32 * (S n))). 102 | clear n. 103 | intros n IND. 104 | destruct n. 105 | unfold sub1_linear_time4. 106 | rewrite sum_S_j; auto. 107 | rewrite sum_eq. 108 | compute. 109 | omega. 110 | 111 | unfold sub1_linear_time4. 112 | rewrite sum_div2. 113 | unfold shift_2x. 114 | unfold shift. 115 | 116 | replace (sum 0 (div2 (S n)) (fun n0 : nat => sub1_time (S (n0 + n0)))) 117 | with (sum 0 (div2 (S n)) (fun n0 => 8)); 118 | [|apply sum_extensionality; intros; rewrite sub1_time_double; auto]. 119 | 120 | unfold sub1_linear_time4 in IND. 121 | 122 | apply (le_trans 123 | (sum 0 (div2 (S (S n))) (fun n0 : nat => sub1_time (n0 + n0)) + 124 | sum 0 (div2 (S n)) (fun _ : nat => 8)) 125 | (sum 0 (div2 (S (S n))) (fun n0 : nat => sub1_time n0 + 12) + 126 | sum 0 (div2 (S n)) (fun _ : nat => 8))). 127 | apply plus_le_compat; auto. 128 | apply sum_preserves_order. 129 | intros n0 _. 130 | apply sub1_time_S_double. 131 | replace (fun n0 : nat => sub1_time n0 + 12) 132 | with (fplus (fun n0 : nat => sub1_time n0) (fun n0 => 12)); 133 | [|unfold fplus; auto]. 134 | 135 | rewrite <- sum_over_fns. 136 | 137 | replace (div2 (S (S n))) with (S (div2 n));[|auto]. 138 | 139 | apply (le_trans 140 | (sum 0 (S (div2 n)) (fun n0 : nat => sub1_time n0) + 141 | sum 0 (S (div2 n)) (fun _ : nat => 12) + 142 | sum 0 (div2 (S n)) (fun _ : nat => 8)) 143 | (32 * (S (div2 n)) + 144 | sum 0 (S (div2 n)) (fun _ : nat => 12) + 145 | sum 0 (div2 (S n)) (fun _ : nat => 8))). 146 | apply plus_le_compat;auto. 147 | apply plus_le_compat;auto. 148 | rewrite (sum_constant 0 (S (div2 n)) 12 (S (div2 n))); auto. 149 | rewrite (sum_constant 0 (div2 (S n)) 8 (div2 (S n))); auto. 150 | 151 | replace (32 * S (div2 n) + (S (div2 n) + 1) * 12 + (div2 (S n) + 1) * 8) 152 | with 153 | (44 * div2 n + 8 * (div2 (S n)) + 64);[|omega]. 154 | replace (32 * (S (S n))) with (32 * n + 64);[|omega]. 155 | apply plus_le_compat;auto. 156 | 157 | destruct (even_odd_dec n). 158 | 159 | (* even case *) 160 | rewrite <- even_div2; auto. 161 | rewrite (even_double n) at 3; auto. 162 | unfold double. 163 | omega. 164 | 165 | rewrite <- odd_div2; auto. 166 | rewrite (odd_double n) at 3; auto. 167 | unfold double. 168 | omega. 169 | Qed. 170 | 171 | Theorem sub1_linear_time_linear : 172 | big_oh sub1_linear_time (fun n => n). 173 | Proof. 174 | apply (big_oh_trans sub1_linear_time sub1_linear_time1). 175 | apply big_oh_eq. 176 | apply sub1_linear_time01. 177 | 178 | apply (big_oh_trans sub1_linear_time1 sub1_linear_time2). 179 | apply sub1_linear_time12. 180 | 181 | apply (big_oh_trans sub1_linear_time2 sub1_linear_time3). 182 | apply big_oh_eq. 183 | apply sub1_linear_time23. 184 | 185 | unfold sub1_linear_time3. 186 | apply big_oh_plus. 187 | 188 | fold sub1_linear_time4. 189 | apply sub1_linear_time4_linear. 190 | 191 | exists 1. 192 | exists 14. 193 | intros n LT. 194 | destruct n. 195 | intuition. 196 | omega. 197 | Qed. 198 | -------------------------------------------------------------------------------- /arith/sub1_linear_loop_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "sub1_gen.rkt") 3 | (provide sub1_linear_loop) 4 | 5 | (Fixpoint 6 | sub1_linear_loop @n{nat} 7 | #:measure n 8 | #:returns @{nat} 9 | (match (n) 10 | [0 => (<== 0)] 11 | [(S _) 12 | => 13 | (bind ([n′ (sub1 n)]) 14 | (bind ([res (sub1_linear_loop n′)]) 15 | (<== res)))])) 16 | -------------------------------------------------------------------------------- /common/array.v: -------------------------------------------------------------------------------- 1 | Require Import Program. 2 | Require Import Omega. 3 | Require Import Braun.common.log Braun.common.big_oh. 4 | Require Import Braun.common.util Braun.common.le_util. 5 | Require Import Arith Arith.Even Arith.Div2 List. 6 | 7 | (* this is http://oeis.org/A001855 *) 8 | Program Fixpoint mat_time n {measure n} := 9 | match n with 10 | | 0 => 0 11 | | S n' => 12 | mat_time (div2 n) + mat_time (div2 n') + n 13 | end. 14 | 15 | Lemma mat_time_Sn : 16 | forall n', 17 | mat_time (S n') = 18 | mat_time (div2 (S n')) + 19 | mat_time (div2 n') + 20 | (S n'). 21 | Proof. 22 | intros. 23 | WfExtensionality.unfold_sub 24 | mat_time 25 | (mat_time (S n')). 26 | auto. 27 | Qed. 28 | 29 | Lemma mat_time_Sn_cl_log : 30 | forall n : nat, 31 | mat_time (S n) = mat_time n + cl_log (S n). 32 | Proof. 33 | apply (well_founded_ind 34 | lt_wf 35 | (fun n => mat_time (S n) = mat_time n + cl_log (S n))). 36 | 37 | intros n IHn. 38 | 39 | destruct n. 40 | compute;reflexivity. 41 | 42 | rewrite mat_time_Sn. 43 | 44 | replace (div2 (S (S n))) with (S (div2 n));[|unfold div2;reflexivity]. 45 | 46 | rewrite IHn;auto. 47 | 48 | replace (cl_log (S (S n))) with (S (cl_log (div2 (S (S n))))); 49 | [|symmetry;apply cl_log_div2']. 50 | 51 | rewrite mat_time_Sn. 52 | 53 | replace (div2 (S (S n))) with (S (div2 n));[|unfold div2;reflexivity]. 54 | 55 | omega. 56 | Qed. 57 | 58 | Lemma braun_implies_mat_time: 59 | forall x y, 60 | y <= x <= y + 1 -> 61 | x + y + mat_time x + mat_time y + 1 = mat_time (S (x + y)). 62 | Proof. 63 | intros x y BTI. 64 | rewrite mat_time_Sn. 65 | 66 | assert (x = y \/ x = y+1) as TWOCASES;[omega|clear BTI]. 67 | destruct TWOCASES; subst x. 68 | 69 | rewrite div2_with_odd_argument. 70 | rewrite double_div2. 71 | omega. 72 | 73 | replace (S (y + 1 + y)) with ((y+1)+(y+1));[|omega]. 74 | replace (y+1+y) with (S (y + y));[|omega]. 75 | rewrite div2_with_odd_argument. 76 | rewrite double_div2. 77 | omega. 78 | Qed. 79 | Hint Resolve braun_implies_mat_time. 80 | 81 | Lemma mat_time_le_nlogn : 82 | forall n, 83 | mat_time n <= n * cl_log n. 84 | Proof. 85 | apply (well_founded_ind 86 | lt_wf 87 | (fun n => mat_time n <= n * cl_log n)). 88 | intros n IND. 89 | destruct n. 90 | compute;constructor. 91 | 92 | rewrite mat_time_Sn. 93 | 94 | apply (le_trans (mat_time (div2 (S n)) + mat_time (div2 n) + S n) 95 | (div2 (S n) * cl_log (div2 (S n)) + 96 | (div2 n) * cl_log (div2 n) + 97 | S n) 98 | (S n * cl_log (S n))). 99 | apply le_plus_left. 100 | 101 | assert (mat_time (div2 (S n)) <= div2 (S n) * cl_log (div2 (S n))); 102 | [apply IND; auto|]. 103 | assert (mat_time (div2 n) <= div2 n * cl_log (div2 n)); 104 | [apply IND;auto|]. 105 | omega. 106 | 107 | rewrite cl_log_div2'. 108 | assert (S n * S (cl_log (div2 (S n))) = (S n) * cl_log (div2 (S n)) + S n) as H; 109 | [rewrite mult_comm; 110 | unfold mult at 1;fold mult; 111 | rewrite plus_comm; 112 | rewrite mult_comm; 113 | reflexivity|rewrite H;clear H]. 114 | 115 | apply le_plus_left. 116 | 117 | apply (le_trans 118 | (div2 (S n) * cl_log (div2 (S n)) + div2 n * cl_log (div2 n)) 119 | (div2 (S n) * cl_log (div2 (S n)) + div2 (S n) * cl_log (div2 (S n))) 120 | (S n * cl_log (div2 (S n)))). 121 | 122 | apply le_plus_right. 123 | 124 | apply le_pieces_le_prod. 125 | apply div2_monotone_Sn. 126 | 127 | assert (even n \/ odd n) as H; [apply even_or_odd|destruct H]. 128 | rewrite even_div2;[|assumption]. 129 | constructor. 130 | 131 | rewrite <- odd_div2;[|assumption]. 132 | apply cl_log_monotone_Sn. 133 | 134 | rewrite mult_comm. 135 | replace (S n * cl_log (div2 (S n))) with (cl_log (div2 (S n)) * S n);[|apply mult_comm]. 136 | apply div2_mult. 137 | Qed. 138 | 139 | 140 | Lemma mat_time_nlogn : big_oh mat_time (fun n => n * cl_log n). 141 | Proof. 142 | exists 0. 143 | exists 1. 144 | intros n LT. 145 | clear LT. 146 | simpl. 147 | rewrite plus_0_r. 148 | apply mat_time_le_nlogn. 149 | Qed. 150 | -------------------------------------------------------------------------------- /common/braun.v: -------------------------------------------------------------------------------- 1 | Require Import Arith Arith.Even Arith.Div2. 2 | Require Import Braun.common.util Omega. 3 | Set Implicit Arguments. 4 | 5 | (* START: bin_tree *) 6 | Inductive bin_tree {A:Set} : Set := 7 | | bt_mt : bin_tree 8 | | bt_node : A -> bin_tree -> bin_tree -> bin_tree. 9 | (* STOP: bin_tree *) 10 | Hint Constructors bin_tree. 11 | 12 | (* START: Braun *) 13 | Inductive Braun {A:Set} : (@bin_tree A) -> nat -> Prop := 14 | | B_mt : Braun bt_mt 0 15 | | B_node : forall (x:A) s s_size t t_size, 16 | t_size <= s_size <= t_size+1 -> 17 | Braun s s_size -> Braun t t_size -> 18 | Braun (bt_node x s t) (s_size+t_size+1). 19 | (* STOP: Braun *) 20 | Hint Constructors Braun. 21 | 22 | Lemma braun_node_construction: 23 | forall (A:Set) (x:A) n s t, 24 | Braun s (div2 (n+1)) -> 25 | Braun t (div2 n) -> 26 | Braun (bt_node x s t) (S n). 27 | Proof. 28 | intros. 29 | replace (S n) with (div2 (n+1) + div2 n + 1). 30 | constructor; auto. 31 | apply (ind_0_1_SS (fun n => div2 n <= div2 (n+1) <= div2 n + 1)); 32 | try (intros;simpl;omega). 33 | rewrite div_ceil_floor_sum. 34 | replace (S n + 1) with (S (S n));[|omega]. 35 | replace (div2 (S (S n))) with (S (div2 n));[|simpl;reflexivity]. 36 | replace (n+1) with (S n);[|omega]. 37 | omega. 38 | Qed. 39 | Hint Resolve braun_node_construction. 40 | -------------------------------------------------------------------------------- /common/index.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.common.braun Braun.common.log Braun.common.util. 2 | Require Import Arith Arith.Even Arith.Div2 List. 3 | Require Import Program. 4 | Require Import Omega. 5 | 6 | Inductive IndexR {A:Set} : (@bin_tree A) -> nat -> A -> Prop := 7 | | IR_zero : 8 | forall x s t, 9 | IndexR (bt_node x s t) 0 x 10 | | IR_left : 11 | forall x s t i y, 12 | IndexR s i y -> 13 | IndexR (bt_node x s t) (2 * i + 1) y 14 | | IR_right : 15 | forall x s t i y, 16 | IndexR t i y -> 17 | IndexR (bt_node x s t) (2 * i + 2) y. 18 | Hint Constructors IndexR. 19 | 20 | Theorem index_dec : 21 | forall A (bt:@bin_tree A) i, 22 | { x | IndexR bt i x } + 23 | { forall x, ~ IndexR bt i x }. 24 | Proof. 25 | intros A bt. 26 | induction bt as [|x s IRs t IRt]; intros i. 27 | 28 | right. intros x IR. 29 | inversion IR. 30 | 31 | destruct i as [|i]. 32 | left. eauto. 33 | 34 | destruct (even_odd_dec i) as [E | O]. 35 | 36 | apply even_2n in E. 37 | destruct E as [k EQ]. subst. 38 | unfold double. 39 | replace (S (k + k)) with (2 * k + 1); try omega. 40 | destruct (IRs k) as [[y IRs_k] | FAIL]. 41 | left. eauto. 42 | right. intros y IR. 43 | inversion IR; clear IR; subst; try omega. 44 | replace i with k in *; try omega. 45 | apply (FAIL y); auto. 46 | 47 | apply odd_S2n in O. 48 | destruct O as [k EQ]. subst. 49 | unfold double. 50 | replace (S (S (k + k))) with (2 * k + 2); try omega. 51 | destruct (IRt k) as [[y IRt_k] | FAIL]. 52 | left. eauto. 53 | right. intros y IR. 54 | inversion IR; clear IR; subst; try omega. 55 | replace i with k in *; try omega. 56 | apply (FAIL y); auto. 57 | Defined. 58 | 59 | Theorem index_Braun : 60 | forall A (bt:@bin_tree A) n, 61 | Braun bt n -> 62 | forall i, 63 | i < n -> 64 | exists x, 65 | IndexR bt i x. 66 | Proof. 67 | induction bt as [|x s Is t It]; 68 | intros n B i LT. 69 | 70 | inversion B. omega. 71 | 72 | inversion B; clear B; subst. 73 | rename H2 into BP. 74 | rename H4 into Bs. 75 | rename H5 into Bt. 76 | destruct i as [|i]. 77 | eauto. 78 | destruct (even_odd_dec i) as [E | O]. 79 | 80 | apply even_2n in E. destruct E as [k EQ]; subst. 81 | unfold double in *. 82 | destruct (Is s_size Bs k) as [y IRs]; try omega. 83 | replace (S (k + k)) with (2 * k + 1); try omega. 84 | eauto. 85 | 86 | apply odd_S2n in O. destruct O as [k EQ]; subst. 87 | unfold double in *. 88 | destruct (It t_size Bt k) as [y IRt]; try omega. 89 | replace (S (S (k + k))) with (2 * k + 2); try omega. 90 | eauto. 91 | Qed. 92 | 93 | Theorem index : 94 | forall A (bt:@bin_tree A) n, 95 | Braun bt n -> 96 | forall i, 97 | i < n -> 98 | { x | IndexR bt i x }. 99 | Proof. 100 | intros A bt n B i LT. 101 | destruct (index_dec A bt i) as [OK | FAIL]. 102 | auto. 103 | assert False; try tauto. 104 | destruct (index_Braun A bt n B i LT) as [y IR]. 105 | apply (FAIL y). auto. 106 | Defined. 107 | -------------------------------------------------------------------------------- /common/pow.v: -------------------------------------------------------------------------------- 1 | Require Import Arith Arith.Even Arith.Div2 Omega. 2 | Require Import Coq.Logic.JMeq Coq.Program.Wf. 3 | Require Import Program.Syntax List. 4 | Require Import Braun.common.util Braun.common.log. 5 | 6 | Fixpoint pow n m := 7 | match m with 8 | | O => 9 | 1 10 | | S m => 11 | n * pow n m 12 | end. 13 | 14 | Lemma pow_2_0 : pow 2 0 = 1. 15 | Proof. 16 | auto. 17 | Qed. 18 | Lemma pow_2_1 : pow 2 1 = 2. 19 | Proof. 20 | auto. 21 | Qed. 22 | Lemma pow_2_2 : pow 2 2 = 4. 23 | Proof. 24 | auto. 25 | Qed. 26 | 27 | Lemma pow2_monotone: 28 | forall x y, 29 | x <= y -> 30 | pow 2 x <= pow 2 y. 31 | Proof. 32 | induction x as [|x]; intros y LE. 33 | simpl. clear LE. 34 | induction y as [|y]. simpl. auto. 35 | simpl. omega. 36 | destruct y as [|y]. omega. 37 | apply le_S_n in LE. 38 | apply IHx in LE. 39 | simpl. omega. 40 | Qed. 41 | 42 | Lemma pow_S_non_zero : 43 | forall m n, 0 < pow (S m) n. 44 | Proof. 45 | intros m n. 46 | induction n. 47 | simpl. 48 | omega. 49 | simpl. 50 | intuition. 51 | Qed. 52 | 53 | Lemma pow2_log : 54 | forall n, cl_log (pow 2 n) = S n. 55 | Proof. 56 | apply (well_founded_ind 57 | lt_wf 58 | (fun n => cl_log (pow 2 n) = (S n))). 59 | intros n IND. 60 | destruct n. 61 | auto. 62 | replace (pow 2 (S n)) with (2 * (pow 2 n));[|unfold pow;auto]. 63 | remember (pow 2 n) as m. 64 | destruct m. 65 | remember (pow_S_non_zero 1 n); intuition. 66 | replace (2 * S m) with (m + 1 + m + 1);[|omega]. 67 | rewrite <- cl_log_even. 68 | replace (m+1) with (S m);[|omega]. 69 | replace (cl_log (S m)+1) with (S (cl_log (S m)));[|omega]. 70 | assert (cl_log (S m) = S n);auto. 71 | rewrite <- (IND n); auto. 72 | Qed. 73 | -------------------------------------------------------------------------------- /common/same_structure.v: -------------------------------------------------------------------------------- 1 | (* prove that there can be only one *) 2 | (* shape braun tree for a given size *) 3 | 4 | Require Import Braun.common.braun Braun.common.util Omega. 5 | Require Import Program.Equality. 6 | Set Implicit Arguments. 7 | 8 | Inductive same_structure {A:Set} : @bin_tree A -> @bin_tree A -> Prop := 9 | | SS_mt : 10 | same_structure bt_mt bt_mt 11 | | SS_node : 12 | forall (x1 x2 : A) l1 l2 r1 r2, 13 | same_structure l1 l2 -> 14 | same_structure r1 r2 -> 15 | same_structure (bt_node x1 l1 r1) 16 | (bt_node x2 l2 r2). 17 | Hint Constructors same_structure. 18 | 19 | Theorem same_structure_same_size : 20 | forall A (bt1:@bin_tree A) bt2, 21 | same_structure bt1 bt2 -> 22 | forall n1 n2, 23 | Braun bt1 n1 -> 24 | Braun bt2 n2 -> 25 | n1 = n2. 26 | Proof. 27 | intros A bt1 bt2 SS. 28 | induction SS; intros n1 n2 B1 B2; 29 | inversion_clear B1; 30 | inversion_clear B2; eauto. 31 | Qed. 32 | Hint Rewrite same_structure_same_size. 33 | 34 | Theorem same_size_same_structure : 35 | forall A n (bt1:@bin_tree A) bt2, 36 | Braun bt1 n -> 37 | Braun bt2 n -> 38 | same_structure bt1 bt2. 39 | Proof. 40 | intros A. 41 | apply (well_founded_ind 42 | lt_wf 43 | (fun n => forall (b1 b2 : bin_tree), 44 | Braun b1 n -> Braun b2 n -> same_structure b1 b2)). 45 | intros n IH bt1 bt2 B1 B2. 46 | dependent destruction bt1; dependent destruction bt2; eauto; 47 | inversion B1; subst; 48 | inversion B2; subst; eauto. 49 | 50 | apply plusone_ne_zero in H2; inversion H2. 51 | symmetry in H. apply plusone_ne_zero in H; inversion H. 52 | assert (s_size = s_size0); try omega. 53 | assert (t_size = t_size0); try omega. 54 | subst. 55 | 56 | eapply SS_node. 57 | eapply IH; eauto; omega. 58 | eapply IH; eauto; omega. 59 | Qed. 60 | Hint Resolve same_size_same_structure. 61 | -------------------------------------------------------------------------------- /common/sequence.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.common.braun Braun.common.util Braun.common.index Braun.common.list_util List. 2 | Require Import Omega. 3 | 4 | Inductive SequenceR {A:Set} : @bin_tree A -> list A -> Prop := 5 | | SR_mt : 6 | SequenceR bt_mt nil 7 | | SR_node : 8 | forall x s t ss ts, 9 | SequenceR s ss -> 10 | SequenceR t ts -> 11 | SequenceR (bt_node x s t) (x::interleave ss ts). 12 | Hint Constructors SequenceR. 13 | 14 | Lemma SR_singleton: 15 | forall (A:Set) (x:A), 16 | SequenceR (bt_node x bt_mt bt_mt) (x :: nil). 17 | Proof. 18 | intros A x. 19 | cut (nil = (@interleave A nil nil)). 20 | intros EQ. rewrite EQ. clear EQ. 21 | eapply SR_node; eauto. 22 | auto. 23 | Qed. 24 | 25 | Lemma BraunR_SequenceR : 26 | forall A (b:@bin_tree A) n, 27 | Braun b n -> 28 | forall l, 29 | SequenceR b l -> 30 | n = (length l). 31 | Proof. 32 | intros A b n B. 33 | induction B; intros l SR; invclr SR. 34 | auto. 35 | 36 | rename H into BP. 37 | rename H4 into SRs. 38 | rename H5 into SRt. 39 | apply IHB1 in SRs. 40 | apply IHB2 in SRt. 41 | subst. 42 | rewrite interleave_length_split. 43 | simpl. 44 | omega. 45 | Qed. 46 | Hint Rewrite BraunR_SequenceR. 47 | 48 | Theorem SequenceR_IndexR : 49 | forall A (b:@bin_tree A) i x, 50 | IndexR b i x -> 51 | forall xs, 52 | Braun b (length xs) -> 53 | SequenceR b xs -> 54 | ListIndexR xs i x. 55 | Proof. 56 | intros A b i x IR. 57 | induction IR; intros xs BP SR; invclr SR; eauto; 58 | rename H3 into SRs; rename H4 into SRt. 59 | 60 | invclr BP. 61 | rename H3 into BP. 62 | rename H4 into Bs. 63 | rename H5 into Bt. 64 | rename H2 into EQ. 65 | rewrite <- interleave_length_split in EQ. 66 | replace s_size with (length ss) in *; try omega. 67 | replace t_size with (length ts) in *; try omega. 68 | apply IHIR in SRs; eauto. 69 | symmetry. eapply BraunR_SequenceR. apply Bs. 70 | apply SRs. 71 | 72 | invclr BP. 73 | rename H3 into BP. 74 | rename H4 into Bs. 75 | rename H5 into Bt. 76 | rename H2 into EQ. 77 | rewrite <- interleave_length_split in EQ. 78 | replace s_size with (length ss) in *; try omega. 79 | replace t_size with (length ts) in *; try omega. 80 | apply IHIR in SRt; eauto. 81 | symmetry. eapply BraunR_SequenceR. apply Bs. 82 | apply SRs. 83 | Qed. 84 | Hint Resolve SequenceR_IndexR. 85 | 86 | Lemma SequenceR_In : 87 | forall A (bt:@bin_tree A) xs, 88 | SequenceR bt xs -> 89 | forall y, 90 | In y xs -> 91 | exists i, 92 | IndexR bt i y. 93 | Proof. 94 | intros A bt xs SR. 95 | induction SR; simpl; intros y; try tauto. 96 | intros [EQ|IN]. 97 | subst. eauto. 98 | apply interleave_In in IN. 99 | destruct IN as [IN|IN]; [ rename IHSR1 into IH | rename IHSR2 into IH ]; 100 | apply IH in IN; destruct IN as [i IR]; eauto. 101 | Qed. 102 | Hint Resolve SequenceR_In. 103 | 104 | Fixpoint mk_list {A:Set} (x:A) (n:nat) := 105 | match n with 106 | | 0 => nil 107 | | S n' => cons x (mk_list x n') 108 | end. 109 | 110 | Lemma interleave_mk_list_same_size : 111 | forall (A:Set) (x:A) n, 112 | interleave (mk_list x n) (mk_list x n) = mk_list x (n+n). 113 | Proof. 114 | induction n; auto. 115 | simpl. 116 | rewrite <- interleave_case2. 117 | rewrite <- interleave_case2. 118 | rewrite IHn. 119 | replace (n + S n) with (S (n + n)); try omega. 120 | auto. 121 | Qed. 122 | 123 | Lemma interleave_constant_lists : 124 | forall (A:Set) ss tt (x:A) n, 125 | interleave ss tt = mk_list x n -> 126 | exists n1 n2, 127 | ss = mk_list x n1 /\ tt = mk_list x n2. 128 | Proof. 129 | induction ss; induction tt. 130 | 131 | (* nil nil *) 132 | intros. 133 | exists 0. 134 | exists 0. 135 | constructor;auto. 136 | 137 | (* cons nil *) 138 | intros x n ILML. 139 | rewrite interleave_nil2 in ILML. 140 | destruct n; simpl in ILML. 141 | inversion ILML. 142 | injection ILML; clear ILML; intros ILML AEQ. 143 | subst a. 144 | exists 0. 145 | exists (S n). 146 | simpl. 147 | subst tt. 148 | split;auto. 149 | 150 | (* nil cons *) 151 | intros x n ILML. 152 | rewrite interleave_nil1 in ILML. 153 | destruct n; simpl in ILML. 154 | inversion ILML. 155 | injection ILML; clear ILML; intros ILML AEQ. 156 | subst a ss. 157 | exists (S n). 158 | exists 0. 159 | simpl. 160 | split; auto. 161 | 162 | (* cons cons *) 163 | intros. 164 | rewrite <- interleave_case2 in H. 165 | rewrite <- interleave_case2 in H. 166 | destruct n; simpl in H. 167 | inversion H. 168 | injection H; clear H; intros. 169 | subst a. 170 | destruct n; simpl in H. 171 | inversion H. 172 | injection H; clear H; intros. 173 | subst a0. 174 | remember (IHss tt x n H) as EN1N2EQ. 175 | clear HeqEN1N2EQ. 176 | destruct EN1N2EQ as [n1 [n2 [SSEQ TTEQ]]]. 177 | subst ss tt. 178 | exists (S n1). 179 | exists (S n2). 180 | simpl. 181 | split; reflexivity. 182 | Qed. 183 | 184 | Lemma sequence_constant_list_index_is_constant : 185 | forall (A:Set) n (x:A) (y:A) i t, 186 | SequenceR t (mk_list x n) 187 | -> IndexR t i y 188 | -> x = y. 189 | Proof. 190 | intros A n x y i t SR IR. 191 | generalize dependent n. 192 | induction IR; intros n SR. 193 | destruct n; simpl in SR. 194 | inversion SR. 195 | inversion SR;auto. 196 | invclr SR. 197 | rename H3 into ILML. 198 | destruct n; simpl in ILML. 199 | inversion ILML. 200 | injection ILML;clear ILML;intros ILML XISX0. 201 | remember (interleave_constant_lists A ss ts x n ILML) as THING. 202 | clear HeqTHING. 203 | destruct THING as [n1 [n2 [SSEQ TSEQ]]]. 204 | subst ss. 205 | apply (IHIR n1); auto. 206 | 207 | destruct n; simpl in SR. 208 | inversion SR. 209 | invclr SR. 210 | rename H4 into ILML. 211 | remember (interleave_constant_lists A ss ts x n ILML) as THING. 212 | clear HeqTHING. 213 | destruct THING as [n1 [n2 [SSEQ TSEQ]]]. 214 | subst ts. 215 | apply (IHIR n2);auto. 216 | Qed. 217 | -------------------------------------------------------------------------------- /copy/copy2_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide copy2) 4 | 5 | (Fixpoint 6 | copy2 #:implicit @A{Set} @x{A} @n{nat} 7 | #:measure n 8 | #:returns @{@"@"bin_tree A * @"@"bin_tree A} 9 | (match (n) 10 | [0 => (<== (pair (bt_node x bt_mt bt_mt) bt_mt))] 11 | [(S n′) 12 | => 13 | (bind ([pr (copy2 x (div2 n′))]) 14 | (match (pr) 15 | [(pair s t) 16 | => 17 | (if (even_odd_dec n′) 18 | (<== (pair (bt_node x s t) (bt_node x t t))) 19 | (<== (pair (bt_node x s s) (bt_node x s t))))]))])) 20 | -------------------------------------------------------------------------------- /copy/copy_fib_log_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (Fixpoint 4 | copy_fib @x{A} @n{nat} 5 | #:measure n 6 | #:returns @{bin_tree} 7 | (match (n) 8 | [0 => (<== bt_mt)] 9 | [_ 10 | => 11 | (if (even_odd_dec n) 12 | (bind ([l (copy_fib x (div2 n))]) 13 | (bind ([r (copy_fib x (- (div2 n) 1))]) 14 | (<== (bt_node x l r)))) 15 | (bind ([t (copy_fib x (div2 n))]) 16 | (<== (bt_node x t t))))])) 17 | -------------------------------------------------------------------------------- /copy/copy_linear.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.index Braun.insert.insert_log. 2 | Require Import Braun.common.braun Braun.common.util Braun.common.big_oh. 3 | Require Import Arith Arith.Even Arith.Div2 Omega. 4 | Require Import Program.Wf. 5 | 6 | Section copy_linear. 7 | 8 | Definition copy_linear_time (n:nat) := 17*n+3. 9 | 10 | Definition copy_linear_result (A:Set) (x:A) (n:nat) (b:@bin_tree A) (c:nat):= 11 | Braun b n /\ 12 | (forall i y, IndexR b i y -> y = x) /\ 13 | c = copy_linear_time (n). 14 | 15 | Load "copy_linear_gen.v". 16 | 17 | Next Obligation. 18 | Proof. 19 | repeat constructor;auto. 20 | intros i y IR. 21 | inversion IR. 22 | Qed. 23 | 24 | Next Obligation. 25 | Proof. 26 | clear H2 am0 H3 am. 27 | destruct H0 as [Br [IRr EQxn]]. 28 | destruct H1 as [Bl [IRl EQxn0]]. 29 | 30 | unfold copy_linear_result. 31 | subst. 32 | 33 | repeat split; auto. 34 | 35 | replace (S n') with (div2 (S n')+ div2(n') + 1). 36 | repeat constructor;auto. 37 | 38 | rewrite (div_ceil_floor_sum n') at 3. 39 | replace (n'+1) with (S n');[|omega]. 40 | omega. 41 | 42 | intros i y IR. invclr IR; eauto. 43 | 44 | unfold copy_linear_time. 45 | replace (17 * div2 (S n') + 3 + (17 * div2 n' + 3 + 14)) 46 | with (17 * (div2 n' + div2 (n'+1)) + 20). 47 | rewrite <- (div_ceil_floor_sum n'). 48 | omega. 49 | 50 | rewrite mult_plus_distr_l. 51 | replace (S n') with (n'+1); omega. 52 | Qed. 53 | 54 | Theorem copy_linear_linear : big_oh copy_linear_time (fun n => n). 55 | Proof. 56 | unfold copy_linear_time; auto. 57 | Qed. 58 | 59 | End copy_linear. 60 | -------------------------------------------------------------------------------- /copy/copy_linear_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide copy_linear) 4 | (Fixpoint 5 | copy_linear #:implicit @A{Set} @x{A} @n{nat} 6 | #:measure n 7 | #:returns @{bin_tree} 8 | (match (n) 9 | [0 => (<== bt_mt)] 10 | [(S n′) 11 | => 12 | (bind ((l (copy_linear x (div2 n)))) 13 | (bind ((r (copy_linear x (div2 n′)))) 14 | (<== (bt_node x l r))))])) 15 | -------------------------------------------------------------------------------- /copy/copy_log.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.index. 2 | Require Import Braun.common.braun Braun.common.log Braun.common.util. 3 | Require Import Braun.common.big_oh. 4 | Require Import Arith Arith.Even Arith.Div2 Omega. 5 | 6 | Definition copy2_rt n := 19 * fl_log n + 8. 7 | 8 | Lemma copy2_rt_Sn : 9 | forall n, 10 | copy2_rt (div2 n) + 19 = copy2_rt (n + 1). 11 | Proof. 12 | intros n. 13 | unfold copy2_rt. 14 | replace (n+1) with (S n);[|omega]. 15 | rewrite fl_log_div2'. 16 | omega. 17 | Qed. 18 | 19 | Definition copy2_result (A:Set) (x:A) n (pr:bin_tree * bin_tree) c := 20 | let (s,t) := pr in 21 | Braun s (n+1) /\ 22 | Braun t n /\ 23 | (forall i y, IndexR s i y -> y = x) /\ 24 | (forall i y, IndexR t i y -> y = x) /\ 25 | c = copy2_rt n. 26 | 27 | Load "copy2_gen.v". 28 | 29 | Next Obligation. 30 | Proof. 31 | (* zero case *) 32 | replace 1 with (0+0+1);[|omega]. 33 | repeat split; try (constructor; try omega; auto). 34 | 35 | intros i y IR; invclr IR. 36 | auto. 37 | invclr H4. 38 | invclr H4. 39 | 40 | intros i y IR; invclr IR. 41 | Qed. 42 | 43 | Next Obligation. 44 | Proof. 45 | (* even case *) 46 | 47 | rename H into EVENn'. 48 | 49 | apply even_double in EVENn'; unfold double in EVENn'. 50 | 51 | (* proof of braun preservation *) 52 | replace (S (n'+1)) with ((div2 n' + 1)+(div2 n')+1);[|omega]. 53 | replace (S n') with (div2 n' + div2 n' + 1);[|omega]. 54 | repeat constructor; try omega; try assumption. 55 | 56 | (* proof of correct elems *) 57 | intros i y IR. clear EVENn'. invclr IR; eauto. 58 | intros i y IR. clear EVENn'. invclr IR; eauto. 59 | 60 | (* proof of running time *) 61 | rewrite <- EVENn'. 62 | apply copy2_rt_Sn. 63 | Qed. 64 | 65 | Next Obligation. 66 | Proof. 67 | (* odd case *) 68 | 69 | rename H into ODDn'. 70 | apply odd_double in ODDn'; unfold double in ODDn'. 71 | 72 | (* proof of braun preservation *) 73 | replace (S (n'+1)) with ((div2 n'+1) + (div2 n'+1) + 1);[|omega]. 74 | replace (S n') with ((div2 n'+1) + (div2 n') + 1);[|omega]. 75 | repeat constructor; try omega; try assumption. 76 | 77 | (* proof of correct elems *) 78 | intros i y IR. clear ODDn'. invclr IR; eauto. 79 | intros i y IR. clear ODDn'. invclr IR; eauto. 80 | 81 | (* proof of running time *) 82 | replace (div2 n' + 1 + div2 n' + 1) with (n'+1);[|omega]. 83 | apply copy2_rt_Sn. 84 | Qed. 85 | 86 | Definition copy_rt n := copy2_rt n + 5. 87 | 88 | Definition copy_result (A:Set) (x:A) (n:nat) (b:@bin_tree A) c := 89 | Braun b n /\ 90 | (forall i y, IndexR b i y -> y = x) /\ 91 | c = copy_rt n. 92 | 93 | Load "copy_log_gen.v". 94 | 95 | Next Obligation. 96 | Proof. 97 | unfold copy_result. 98 | unfold copy2_result in *. 99 | intuition. 100 | Qed. 101 | 102 | Theorem copy_logn : big_oh copy_rt fl_log. 103 | Proof. 104 | apply (big_oh_trans copy_rt 105 | (fun n => fl_log n + 15) 106 | fl_log). 107 | exists 0. 108 | exists 19. 109 | intros. 110 | unfold copy_rt. 111 | unfold copy2_rt. 112 | omega. 113 | 114 | exists 1. 115 | exists 16. 116 | intros n LE. 117 | destruct n; intuition. 118 | clear LE. 119 | rewrite <- fl_log_div2. 120 | omega. 121 | Qed. 122 | -------------------------------------------------------------------------------- /copy/copy_log_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (require "copy2_gen.rkt") 4 | 5 | (Fixpoint 6 | copy #:implicit @A{Set} @x{A} @n{nat} 7 | #:returns @{@"@"bin_tree A} 8 | (bind ([pr (copy2 x n)]) 9 | (match (pr) 10 | [(pair s t) => (<== t)]))) 11 | 12 | (provide copy) 13 | 14 | -------------------------------------------------------------------------------- /copy/copy_log_sq_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "../insert/insert_log_gen.rkt") 3 | (provide copy_log_sq) 4 | (Fixpoint 5 | copy_log_sq #:implicit @A{Set} @x{A} @n{nat} 6 | #:measure n 7 | #:returns @{bin_tree} 8 | (match (n) 9 | [0 => (<== bt_mt)] 10 | [(S n′) 11 | => 12 | (bind ((t (copy_log_sq x (div2 n′)))) 13 | (if (even_odd_dec n′) 14 | (<== (bt_node x t t)) 15 | (bind ((s (insert x t))) 16 | (<== (bt_node x s t)))))])) 17 | -------------------------------------------------------------------------------- /extract/extract.v: -------------------------------------------------------------------------------- 1 | Require Import Arith.Div2 Arith.Even. 2 | 3 | Require Import Braun.insert.insert_log. 4 | 5 | Require Import Braun.copy.copy_linear Braun.copy.copy_fib_log. 6 | Require Import Braun.copy.copy_log_sq Braun.copy.copy_log. 7 | 8 | Require Import Braun.size.size_linear Braun.size.size_log_sq. 9 | 10 | Require Import Braun.make_array.make_array_nlogn1. 11 | Require Import Braun.make_array.make_array_nlogn1_fold. 12 | Require Import Braun.make_array.make_array_nlogn2. 13 | Require Import Braun.to_list.to_list_naive. 14 | 15 | Require Import Braun.monad.monad. 16 | 17 | Require Import Braun.arith.sub1. 18 | Require Import Braun.arith.add1. 19 | Require Import Braun.arith.plus. 20 | 21 | Require Import Braun.sort.isort. 22 | Require Import Braun.sort.mergesort. 23 | 24 | Require Import Braun.fib.fib Braun.fib.fib_iter Braun.fib.fib_rec. 25 | Require Import Braun.zippers.zip. 26 | Require Import Braun.rbtrees.rbt_search. 27 | Require Import Braun.rbtrees.rbt_insert. 28 | 29 | Extract Inductive bool => "bool" [ "false" "true" ]. 30 | Extract Inductive sumbool => "bool" [ "false" "true" ]. 31 | Extract Inductive prod => "(*)" [ "(,)" ]. 32 | 33 | Extract Inductive nat => 34 | "big_int" [ "zero_big_int" "succ_big_int" ] 35 | "(fun fO fS n -> if (eq_big_int n zero_big_int) then fO () else fS (pred_big_int n))". 36 | 37 | Extract Constant plus => "add_big_int". 38 | Extract Constant mult => "mult_big_int". 39 | Extract Constant minus => "sub_big_int". 40 | 41 | Extract Constant div2 => "fun a -> div_big_int a (big_int_of_int 2)". 42 | Extract Constant even_odd_dec => "fun a -> not (eq_big_int zero_big_int (mod_big_int a (big_int_of_int 2)))". 43 | 44 | Extract Inductive sigT => "(*)" [ "(,)" ]. 45 | 46 | Extraction Inline ret bind inc. 47 | Extraction Inline projT1 projT2. 48 | 49 | Extraction "post_extract.ml" 50 | 51 | ret bind inc 52 | 53 | insert_log.insert 54 | size_linear.size_linear 55 | size_log_sq.size 56 | 57 | copy_linear.copy_linear 58 | copy_fib_log.copy_fib 59 | copy_log_sq.copy_log_sq 60 | copy_log.copy 61 | 62 | make_array_nlogn1.make_array_naive 63 | make_array_nlogn1_fold.make_array_naive 64 | make_array_nlogn2.make_array_td 65 | to_list_naive.to_list_naive 66 | 67 | arith.sub1.sub1 68 | arith.add1.add1 69 | arith.plus.tplus 70 | 71 | sort.isort.isort 72 | sort.mergesort.mergesort 73 | 74 | fib.fib_rec.fib_rec 75 | fib.fib_iter.fib_iter 76 | 77 | zippers.zip.minsert_at 78 | zippers.zip.minsertz_at 79 | rbtrees.rbt_search.bst_search 80 | rbtrees.rbt_insert.rbt_insert. 81 | -------------------------------------------------------------------------------- /fib/fib_iter_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | 3 | (require "fib_iter_loop_gen.rkt") 4 | (provide fib_iter) 5 | 6 | (Fixpoint 7 | fib_iter @target{nat} 8 | #:returns @{nat} 9 | (match (target) 10 | [0 => (<== 0)] 11 | [(S target′) 12 | => 13 | (match (target′) 14 | [0 => (<== 1)] 15 | [(S target′′) 16 | => 17 | (bind ((res (fib_iter_loop target′ target 0 1))) 18 | (<== res))])])) 19 | -------------------------------------------------------------------------------- /fib/fib_iter_loop_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | (require "../arith/plus_gen.rkt") 3 | (provide fib_iter_loop) 4 | 5 | (Fixpoint 6 | fib_iter_loop @fuel{nat} @target{nat} @a{nat} @b{nat} 7 | #:returns @{nat} 8 | (match (fuel) 9 | [0 => (<== b)] 10 | [(S fuel) 11 | => 12 | (bind ((sum (tplus a b))) 13 | (bind ((res (fib_iter_loop fuel target b sum))) 14 | (<== res)))])) 15 | -------------------------------------------------------------------------------- /fib/fib_rec.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.common.util Braun.common.le_util. 2 | Require Import Braun.common.log Braun.common.big_oh Braun.common.pow. 3 | Require Import Braun.monad.monad Braun.arith.plus Braun.fib.fib. 4 | Require Import Program Div2 Omega Even. 5 | 6 | 7 | Fixpoint fib_rec_time (n:nat) := 8 | match n with 9 | | O => 1 10 | | S n' => 11 | match n' with 12 | | O => 1 13 | | S n'' => (fib_rec_time n'') + (fib_rec_time n') + 1 14 | end 15 | end. 16 | 17 | Definition fib_rec_result (n:nat) (res:nat) (c:nat) := 18 | Fib n res /\ 19 | c = fib_rec_time n. 20 | 21 | Load "fib_rec_gen.v". 22 | 23 | Next Obligation. 24 | Proof. 25 | split;eauto. 26 | Qed. 27 | 28 | Next Obligation. 29 | Proof. 30 | split;eauto. 31 | Qed. 32 | 33 | Next Obligation. 34 | Proof. 35 | clear am H3 am0 H2. 36 | rename H1 into FR_A. 37 | rename H0 into FR_B. 38 | 39 | destruct FR_A as [FIBA FIBTIMEA]. 40 | destruct FR_B as [FIBB FIBTIMEB]. 41 | unfold fib_rec_result in *. 42 | split. 43 | eauto. 44 | rename n'' into n. 45 | destruct n as [|n]; subst; simpl; omega. 46 | Qed. 47 | 48 | Program Lemma fib_big_oh_fib: 49 | big_oh fib fib_rec_time. 50 | Proof. 51 | exists 0 1. 52 | apply (well_founded_induction lt_wf (fun n => 0 <= n -> fib n <= 1 * (fib_rec_time n))). 53 | intros n IH _. 54 | destruct n as [|n]. simpl. omega. 55 | destruct n as [|n]. simpl. auto. 56 | replace (fib_rec_time (S (S n))) with 57 | ((fib_rec_time n) + (fib_rec_time (S n)) + 1); auto. 58 | 59 | assert (fib n <= 1 * (fib_rec_time n)) as IHn. 60 | eapply IH. auto. omega. 61 | assert (fib (S n) <= 1 * (fib_rec_time (S n))) as IHSn. 62 | eapply IH. auto. omega. 63 | 64 | rewrite mult_1_l in *. 65 | 66 | clear IH. 67 | replace (fib (S (S n))) with (fib n + fib (S n)); auto. 68 | omega. 69 | Qed. 70 | 71 | Fixpoint fib_rec_time2 (n:nat) := 72 | match n with 73 | | O => 0 74 | | S n' => 75 | match n' with 76 | | O => 1 77 | | S n'' => (fib_rec_time2 n'') + (fib_rec_time2 n') + 1 78 | end 79 | end. 80 | 81 | Lemma fib_rec_time12 : big_oh fib_rec_time fib_rec_time2. 82 | Proof. 83 | exists 1 11. 84 | intros n LT. 85 | destruct n. intuition. 86 | clear LT. 87 | apply (well_founded_induction 88 | lt_wf 89 | (fun n => fib_rec_time (S n) <= 11 * (fib_rec_time2 (S n)))). 90 | clear n; intros n IND. 91 | destruct n. 92 | simpl. 93 | omega. 94 | destruct n. 95 | simpl. 96 | omega. 97 | replace (fib_rec_time (S (S (S n)))) 98 | with (fib_rec_time (S n) + fib_rec_time (S (S n)) + 1); 99 | [|unfold fib_rec_time;omega]. 100 | replace (fib_rec_time2 (S (S (S n)))) 101 | with (fib_rec_time2 (S n) + fib_rec_time2 (S (S n)) + 1); 102 | [|unfold fib_rec_time2;omega]. 103 | repeat (rewrite mult_plus_distr_l). 104 | apply plus_le_compat. 105 | apply plus_le_compat;apply IND;auto. 106 | omega. 107 | Qed. 108 | 109 | Lemma fib_rec_time2_fib_relationship : 110 | forall n, fib_rec_time2 n + 1 = (fib (S (S n))). 111 | Proof. 112 | intros. 113 | apply (well_founded_induction 114 | lt_wf 115 | (fun n => fib_rec_time2 n + 1 = (fib (S (S n))))). 116 | clear n; intros n IND. 117 | destruct n. 118 | simpl; reflexivity. 119 | destruct n. 120 | simpl; reflexivity. 121 | replace (fib_rec_time2 (S (S n))) with (fib_rec_time2 (S n) + fib_rec_time2 n + 1); 122 | [|unfold fib_rec_time2;omega]. 123 | rewrite fib_SS. 124 | replace (fib_rec_time2 (S n) + fib_rec_time2 n + 1 + 1) 125 | with ((fib_rec_time2 (S n) + 1) + (fib_rec_time2 n + 1));[|omega]. 126 | rewrite IND; auto. 127 | Qed. 128 | 129 | Lemma fib_rec_time23 : big_oh fib_rec_time2 fib. 130 | Proof. 131 | exists 0 3. 132 | intros n _. 133 | assert ((fib_rec_time2 n + 1) <= S (3 * fib n));[|omega]. 134 | rewrite fib_rec_time2_fib_relationship. 135 | replace (S (3 * fib n)) with (3 * fib n + 1);[|omega]. 136 | rewrite fib_SS. 137 | replace (3 * fib n + 1) with (2 * fib n + 1 + fib n);[|omega]. 138 | apply plus_le_compat; auto. 139 | destruct n. 140 | simpl. 141 | omega. 142 | rewrite fib_SS. 143 | replace (2 * fib (S n) + 1) with (fib (S n) + (fib (S n) + 1));[|omega]. 144 | apply plus_le_compat;auto. 145 | apply le_plus_trans. 146 | apply fib_monotone; auto. 147 | Qed. 148 | 149 | Theorem fib_big_theta_fib: 150 | big_theta fib fib_rec_time. 151 | Proof. 152 | split. 153 | apply fib_big_oh_fib. 154 | apply big_oh_rev. 155 | apply (big_oh_trans fib_rec_time fib_rec_time2). 156 | apply fib_rec_time12. 157 | apply fib_rec_time23. 158 | Qed. 159 | 160 | -------------------------------------------------------------------------------- /fib/fib_rec_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad 2 | 3 | (Fixpoint 4 | fib_rec @n{nat} 5 | #:returns @{nat} 6 | (match (n) 7 | [0 => (<== 0)] 8 | [(S n′) 9 | => 10 | (match (n′) 11 | [0 => (<== 1)] 12 | [(S n′′) 13 | => 14 | (bind ((a (fib_rec n′′))) 15 | (bind ((b (fib_rec n′))) 16 | (<== (+ a b))))])])) 17 | -------------------------------------------------------------------------------- /fold/fold.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.common.braun Braun.common.util Braun.common.same_structure. 2 | Require Import Braun.common.log Braun.common.sequence Braun.common.list_util. 3 | Require Import Braun.monad.monad. 4 | Require Import Program List. 5 | Require Import Omega. 6 | 7 | Section foldr. 8 | Variables A B : Set. 9 | Variable P : B -> (list A) -> nat -> Prop. 10 | 11 | Definition f_type := forall (x:A) (acc:B), 12 | {! acc' !:! B !! 13 | forall xs accC, 14 | P acc xs accC -> 15 | P acc' (x :: xs) (c + accC + 10) !}. 16 | 17 | Definition base_type := {bv : B | (P bv nil 4)}. 18 | 19 | Definition foldr_result 20 | (f : f_type) 21 | (pr : base_type) 22 | l 23 | (res:B) 24 | (c : nat) := P res l c. 25 | 26 | Load "fold_gen.v". 27 | 28 | Next Obligation. 29 | unfold base_type in base. 30 | unfold foldr_result. 31 | destruct base. 32 | apply p. 33 | Qed. 34 | 35 | Next Obligation. 36 | unfold foldr_result. 37 | replace (an0 + (an + 10)) with (an + an0 + 10); try omega. 38 | auto. 39 | Defined. 40 | 41 | End foldr. 42 | 43 | Hint Unfold foldr_result. 44 | 45 | Arguments foldr [A] [B] P f base l. 46 | 47 | Program Definition sum (l:list nat) 48 | : {! n !:! nat !! 49 | (forall x, In x l -> x <= n) 50 | /\ c = 13 * length l + 4 !} 51 | := 52 | n <- (foldr (fun b al n => 53 | (forall x, In x al -> x <= b) 54 | /\ n = 13 * length al + 4) 55 | (fun x y => += 3; <== plus x y) 56 | 0 l) ; 57 | <== n. 58 | 59 | Next Obligation. 60 | rename H0 into CR. 61 | split; [| omega]. 62 | intros x0 OR. 63 | inversion OR as [EQ|IN]. 64 | omega. 65 | remember (CR x0 IN). 66 | omega. 67 | Qed. 68 | 69 | Next Obligation. 70 | tauto. 71 | Qed. 72 | 73 | Next Obligation. 74 | unfold foldr_result in *. 75 | split. 76 | tauto. 77 | omega. 78 | Qed. 79 | 80 | (* example use of foldr *) 81 | Program Definition list_id (A : Set) (l : list A) : {! l' !:! list A !! 82 | l' = l !} := 83 | foldr (fun xs ys n => xs = ys) 84 | (fun x ys => <== (cons x ys)) 85 | nil 86 | l. 87 | -------------------------------------------------------------------------------- /fold/fold_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide foldr) 3 | 4 | (Fixpoint 5 | foldr @f{f_type} @base{base_type} @l{list A} 6 | #:returns @{B} 7 | (match (l) 8 | [(nil) => (<== (proj1_sig base))] 9 | [(cons x xs) 10 | => 11 | (bind ((acc (foldr f base xs))) 12 | (bind ((out (f x acc))) 13 | (<== out)))])) 14 | -------------------------------------------------------------------------------- /insert/insert_log.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.common.braun Braun.common.util Braun.common.same_structure. 2 | Require Import Braun.common.log Braun.common.big_oh. 3 | Require Import Braun.common.sequence Braun.common.list_util. 4 | Require Import Braun.monad.monad. 5 | Require Import Program. 6 | Require Import Omega. 7 | 8 | (* START: insert_result *) 9 | Definition insert_time n := 9 * fl_log n + 6. 10 | Definition insert_result (A : Set) (i : A) (b:bin_tree) (res:bin_tree) c := 11 | (forall n, Braun b n -> 12 | (Braun res (S n) /\ 13 | (forall xs, SequenceR b xs -> SequenceR res (i::xs)) /\ 14 | c = insert_time n)). 15 | (* STOP: insert_result *) 16 | 17 | Load "insert_log_gen.v". 18 | 19 | Next Obligation. 20 | unfold insert_result. 21 | intros n B. 22 | invclr B. 23 | repeat constructor; auto. 24 | 25 | (* correctness *) 26 | intros xs SR. 27 | invclr SR. 28 | apply SR_singleton. 29 | Qed. 30 | 31 | Lemma same_tree_same_size : 32 | forall A (s:@bin_tree A) n m, 33 | Braun s n -> 34 | Braun s m -> 35 | n = m. 36 | Proof. 37 | intros A s n m Bn Bm. 38 | apply (@same_structure_same_size _ s s); eauto. 39 | Qed. 40 | Hint Rewrite same_tree_same_size. 41 | 42 | Next Obligation. 43 | clear H1 am. 44 | rename H0 into IH. 45 | unfold insert_result in *. 46 | 47 | intros n B. 48 | 49 | invclr B. 50 | rename H2 into BP. 51 | rename H4 into Bs. 52 | rename H5 into Bt. 53 | 54 | apply IH in Bt. 55 | destruct Bt as [Bst [SRst EQ]]. 56 | subst an. 57 | 58 | repeat constructor. 59 | 60 | (* braun *) 61 | replace (S (s_size + t_size + 1)) with ((S t_size) + s_size + 1); try omega. 62 | eapply B_node; auto; try omega. 63 | 64 | (* correctness *) 65 | intros xs SR. 66 | invclr SR. 67 | rename H3 into SRs. 68 | rename H4 into SRt. 69 | rewrite interleave_case2. 70 | eapply SR_node; eauto. 71 | 72 | (* running time*) 73 | unfold insert_time. 74 | rewrite <- braun_invariant_implies_fl_log_property; auto. 75 | omega. 76 | Qed. 77 | 78 | Theorem insert_time_log: 79 | big_oh insert_time fl_log. 80 | Proof. 81 | apply (big_oh_trans insert_time 82 | (fun n => fl_log n + 6) 83 | fl_log). 84 | exists 0. 85 | exists 9. 86 | intros n LE. 87 | unfold insert_time. 88 | omega. 89 | 90 | exists 1. 91 | exists 7. 92 | intros n LE. 93 | destruct n; intuition. 94 | clear LE. 95 | rewrite <- fl_log_div2. 96 | unfold mult. 97 | omega. 98 | Qed. 99 | -------------------------------------------------------------------------------- /insert/insert_log_gen.rkt: -------------------------------------------------------------------------------- 1 | #reader tmonad/coq 2 | 3 | Provide insert. 4 | 5 | (* START: insert *) 6 | Program Fixpoint insert 7 | {A:Set} (i:A) (b:@bin_tree A) 8 | : @bin_tree A := 9 | match b with 10 | | bt_mt => 11 | <== bt_node i bt_mt bt_mt 12 | | bt_node j s t => 13 | t' <- insert j t; 14 | <== bt_node i t' s 15 | end. 16 | (* STOP: insert *) 17 | -------------------------------------------------------------------------------- /insert/insert_nogen.v: -------------------------------------------------------------------------------- 1 | (* 2 | 3 | This file shows a simplified version of insert, where the correctness 4 | condition is omitted and the "automatically insert the +=" 5 | transformation is not used. It is here to aid the exposition in the 6 | paper. 7 | 8 | *) 9 | 10 | Require Import Braun.common.braun Braun.common.util. 11 | Require Import Braun.common.log Braun.common.big_oh. 12 | Require Import Braun.monad.monad. 13 | Require Import Program. 14 | Require Import Omega. 15 | 16 | (* START: insert *) 17 | Program Fixpoint insert {A:Set} (i:A) (b:@bin_tree A) 18 | : {! res !:! @bin_tree A !! 19 | (forall n, Braun b n -> (Braun res (n+1) /\ c = fl_log n + 1)) !} := 20 | match b with 21 | | bt_mt => += 1; <== (bt_node i bt_mt bt_mt) 22 | | bt_node j s t => t' <- insert j t; 23 | += 1; <== (bt_node i t' s) 24 | end. 25 | (* STOP: insert *) 26 | 27 | Next Obligation. 28 | rename H0 into B. 29 | 30 | invclr B. 31 | simpl. 32 | repeat constructor; auto. 33 | Qed. 34 | 35 | Next Obligation. 36 | clear H2 am. 37 | rename H0 into IH. 38 | rename H1 into B. 39 | 40 | invclr B. 41 | rename H2 into BP. 42 | rename H4 into Bs. 43 | rename H5 into Bt. 44 | 45 | apply IH in Bt. 46 | destruct Bt as [Bst EQ]. 47 | subst an. 48 | 49 | split. 50 | 51 | (* braun *) 52 | replace (t_size + 1) with (S t_size) in Bst; try omega. 53 | replace (s_size + t_size + 1 + 1) with ((S t_size) + s_size + 1); try omega. 54 | eapply B_node; auto; try omega. 55 | 56 | (* running time*) 57 | rewrite <- braun_invariant_implies_fl_log_property; auto. 58 | Qed. 59 | -------------------------------------------------------------------------------- /make_array/build.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.util Braun.common.le_util. 2 | Require Import Braun.common.big_oh Braun.common.braun. 3 | Require Import Braun.make_array.take_drop_split. 4 | Require Import Arith Arith.Le Arith.Lt Peano Arith.Min. 5 | Require Import Coq.Arith.Compare_dec. 6 | Require Import Program.Wf Init.Wf. 7 | 8 | Include WfExtensionality. 9 | 10 | Definition zip_with_3_bt_node_time len := 16 * len + 3. 11 | Hint Unfold zip_with_3_bt_node_time. 12 | 13 | Definition zip_with_3_bt_node_result 14 | (A:Set) (xs:list A) 15 | (ts1:list (@bin_tree A)) (ts2:list (@bin_tree A)) 16 | (res:list (@bin_tree A)) c := 17 | length xs <= length ts1 /\ length xs <= length ts2 -> 18 | c = zip_with_3_bt_node_time (length xs). 19 | Hint Unfold zip_with_3_bt_node_result. 20 | 21 | Load "zip_with_3_bt_node_gen.v". 22 | 23 | Next Obligation. 24 | Proof. 25 | unfold zip_with_3_bt_node_result. 26 | intros LENS. 27 | destruct LENS as [L1 L2]. 28 | simpl in L1. 29 | intuition. 30 | Qed. 31 | 32 | Next Obligation. 33 | Proof. 34 | unfold zip_with_3_bt_node_result. 35 | intros LENS. 36 | destruct LENS as [L1 L2]. 37 | simpl in L2. 38 | intuition. 39 | Qed. 40 | 41 | Next Obligation. 42 | Proof. 43 | clear am H1. 44 | rename H0 into ZWRES. 45 | 46 | unfold zip_with_3_bt_node_result in *. 47 | unfold zip_with_3_bt_node_time in *. 48 | simpl. 49 | omega. 50 | Qed. 51 | 52 | Lemma zip_with_3_bt_node_linear : big_oh zip_with_3_bt_node_time (fun n => n). 53 | Proof. 54 | unfold zip_with_3_bt_node_time. 55 | auto. 56 | Qed. 57 | 58 | Definition build_time k len := 59 | pad_drop_time (2*k) + 60 | split_time (2*k) k + 61 | zip_with_3_bt_node_time len + 62 | 16. 63 | Hint Unfold build_time. 64 | 65 | Definition build_result 66 | (A:Set) 67 | (pr:nat * list A) 68 | (ts : list (@bin_tree A)) 69 | (res : list (@bin_tree A)) 70 | c := 71 | (length (snd pr) <= fst pr) -> 72 | c = build_time (fst pr) (length (snd pr)). 73 | Hint Unfold build_result. 74 | 75 | Load "build_gen.v". 76 | 77 | Next Obligation. 78 | Proof. 79 | clear am am0 am1 H3 H4 H5. 80 | rename H0 into ZWres. 81 | rename H2 into PDres. 82 | rename H1 into SPLITres. 83 | unfold build_result. 84 | unfold build_time. 85 | unfold zip_with_3_bt_node_result in *. 86 | unfold pad_drop_result in *. 87 | unfold split_result in *. 88 | simpl in SPLITres. 89 | simpl. 90 | destruct SPLITres as [AN0eq [SHORT LONG]]. 91 | clear SHORT. 92 | destruct PDres as [AN1eq LENpadded]. 93 | rewrite LENpadded in *. 94 | replace (n + (n+0)-n) with n in LONG;[|omega]. 95 | assert (length l = n /\ length l0 = n) as LENS;[apply LONG; omega|clear LONG]. 96 | destruct LENS as [LENl LENl0]. 97 | rewrite LENl in *. 98 | rewrite LENl0 in *. 99 | clear LENl LENl0. 100 | intros LENl1. 101 | assert (an = zip_with_3_bt_node_time (length l1));[apply ZWres; auto|]. 102 | subst an1 an0 an. 103 | omega. 104 | Qed. 105 | -------------------------------------------------------------------------------- /make_array/build_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "zip_with_3_bt_node_gen.rkt" 3 | "pad_drop_gen.rkt" 4 | "split_gen.rkt") 5 | 6 | (provide build) 7 | 8 | (Fixpoint 9 | build 10 | #:implicit @A{Set} 11 | @pr{nat * list A} 12 | @ts{list (@"@"bin_tree A)} 13 | #:returns @{list (@"@"bin_tree A)} 14 | (match (pr) 15 | [(pair k xs) 16 | => 17 | (bind ([padded (pad_drop (* 2 k) ts bt_mt)]) 18 | (bind ([ts1ts2 (split k padded)]) 19 | (match (ts1ts2) 20 | [(pair ts1 ts2) 21 | => 22 | (bind ([zipped (zip_with_3_bt_node xs ts1 ts2)]) 23 | (<== zipped))])))])) 24 | -------------------------------------------------------------------------------- /make_array/drop_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide drop) 3 | 4 | (Fixpoint 5 | drop #:implicit @A{Set} @n{nat} @xs{list A} 6 | #:returns @{list A} 7 | (match (n) 8 | [0 => (<== xs)] 9 | [(S n′) 10 | => 11 | (match (xs) 12 | [(nil) => (<== nil)] 13 | [(cons x xs) 14 | => 15 | (bind ([tl (drop n′ xs)]) 16 | (<== tl))])])) 17 | -------------------------------------------------------------------------------- /make_array/foldr_build_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "build_gen.rkt") 3 | 4 | (provide foldr_build) 5 | 6 | (Fixpoint 7 | foldr_build #:implicit @A{Set} @base{list (@"@"bin_tree A)} @l{list (nat * list A)} 8 | #:returns @{list (@"@"bin_tree A)} 9 | (match (l) 10 | [(nil) => (<== base)] 11 | [(cons x xs) 12 | => 13 | (bind ((acc (foldr_build base xs))) 14 | (bind ((out (build x acc))) 15 | (<== out)))])) 16 | -------------------------------------------------------------------------------- /make_array/make_array_linear_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "rows1_gen.rkt" "../fold/fold_gen.rkt" "foldr_build_gen.rkt") 3 | 4 | (provide make_array_linear) 5 | 6 | (Fixpoint 7 | make_array_linear 8 | #:implicit @A{Set} 9 | @xs{list A} 10 | #:returns @{@"@"bin_tree A} 11 | (bind ((the_rows (rows1 xs))) 12 | (bind ((built (foldr_build (cons bt_mt nil) the_rows))) 13 | (match (built) 14 | ;; this first case should never happen 15 | [(nil) => (<== bt_mt)] 16 | ;; ts′ should always be nil 17 | [(cons t ts′) => (<== t)])))) 18 | -------------------------------------------------------------------------------- /make_array/make_array_nlogn1.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad. 2 | Require Import Braun.insert.insert_log. 3 | 4 | Require Import Braun.common.sequence. 5 | 6 | Require Import Braun.common.braun. 7 | Require Import Braun.common.array. 8 | Require Import Braun.common.util. 9 | Require Import Braun.common.big_oh. 10 | Require Import Braun.common.log Braun.common.le_util. 11 | Require Import Arith Arith.Even Arith.Div2 Omega. 12 | 13 | Fixpoint man_time' n : nat := 14 | match n with 15 | | 0 => 3 16 | | S n' => man_time' n' + 9 * (fl_log n') + 14 17 | end. 18 | 19 | Definition make_array_naive_result (A:Set) (xs:list A) (b : @bin_tree A) c := 20 | let n := length xs in 21 | Braun b n 22 | /\ c = man_time' n 23 | /\ SequenceR b xs. 24 | Hint Unfold make_array_naive_result. 25 | 26 | Load "make_array_nlogn1_gen.v". 27 | 28 | Next Obligation. 29 | Proof. 30 | clear H2 H3. 31 | rename H1 into MANRxs'. 32 | rename H0 into IRbt. 33 | 34 | destruct MANRxs' as [BTbt [EQxm SRbt]]. 35 | 36 | unfold insert_result in *. 37 | remember (IRbt (length xs') BTbt) as ONE; clear HeqONE IRbt. 38 | destruct ONE as [BRir [SRimpl EQxm0]]. 39 | 40 | repeat split; auto. 41 | subst. 42 | simpl. 43 | unfold insert_time. 44 | omega. 45 | Qed. 46 | 47 | Lemma man_time'_nlogn_helper: 48 | forall n, 49 | n * (9 * (fl_log n) + 14) + 3 <= 50 | 23 * n * fl_log n + 3. 51 | Proof. 52 | intros n. 53 | apply le_plus_left. 54 | replace (n * (9 * fl_log n + 14)) with (9 * n * fl_log n + 14 * n). 55 | replace (23*n*fl_log n) with (9 * n * fl_log n + 14 * n * fl_log n). 56 | apply le_plus_right. 57 | replace (14 * n * fl_log n) with (14 * (n * fl_log n)). 58 | apply le_mult_right. 59 | 60 | destruct n; auto. 61 | 62 | assert (S n = S n * 1) as H;[omega|rewrite H at 1; clear H]. 63 | apply le_mult_right. 64 | apply one_le_fl_log_S. 65 | 66 | apply mult_assoc. 67 | 68 | replace 23 with (9+14);[|omega]. 69 | rewrite <- mult_plus_distr_r. 70 | replace ((9+14)*n) with (9*n+14*n); 71 | [reflexivity|rewrite mult_plus_distr_r;reflexivity]. 72 | 73 | rewrite mult_plus_distr_l. 74 | replace (n * (9 * fl_log n)) with ((n * 9) * fl_log n); 75 | [|rewrite mult_assoc;reflexivity]. 76 | replace (9*n) with (n*9); [|apply mult_comm]. 77 | replace (14*n) with (n*14); [|apply mult_comm]. 78 | reflexivity. 79 | Qed. 80 | 81 | Lemma man_time'_nlogn_help: 82 | forall n, 83 | man_time' n <= 23 * n * (fl_log n) + 3. 84 | Proof. 85 | intros n. 86 | apply (le_trans (man_time' n) 87 | (n * (9 * (fl_log n) + 14) + 3) 88 | (23 * n * fl_log n + 3)); try (apply man_time'_nlogn_helper). 89 | 90 | induction n as [|n]. 91 | simpl; omega. 92 | 93 | unfold man_time'; fold man_time'. 94 | 95 | apply (le_trans (man_time' n + 9 * fl_log n + 14) 96 | ((n * (9 * fl_log n + 14) + 3) + 9 * fl_log n + 14) 97 | (S n * (9 * fl_log (S n) + 14) + 3)). 98 | 99 | repeat (apply le_plus_left). 100 | assumption. 101 | 102 | replace (S n * (9 * fl_log (S n) + 14)) 103 | with (n * (9 * fl_log (S n) + 14) + (9 * fl_log (S n) + 14)). 104 | 105 | assert (n * (9 * fl_log n + 14) <= n * (9 * fl_log (S n) + 14)). 106 | apply le_mult_right. 107 | apply le_plus_left. 108 | apply le_mult_right. 109 | apply fl_log_monotone_Sn. 110 | 111 | assert (9 * fl_log n + 14 <= 9 * fl_log (S n) + 14). 112 | apply le_plus_left. 113 | apply le_mult_right. 114 | apply fl_log_monotone_Sn. 115 | omega. 116 | 117 | unfold mult; fold mult; omega. 118 | Qed. 119 | 120 | Lemma nlogn_plus_3_is_n_log_n: 121 | big_oh (fun n => n * fl_log n + 3) 122 | (fun n => n * fl_log n). 123 | Proof. 124 | exists 1. 125 | exists 8. 126 | intros n LE. 127 | destruct n; intuition. 128 | clear LE. 129 | rewrite <- fl_log_div2. 130 | rewrite mult_plus_distr_l. 131 | rewrite mult_plus_distr_l. 132 | apply (le_trans (S n * fl_log (div2 n) + S n * 1 + 3) 133 | (S n * fl_log (div2 n) + 8 * (S n * 1)) 134 | (8 * (S n * fl_log (div2 n)) + 8 * (S n * 1))). 135 | rewrite <- plus_assoc. 136 | apply le_plus_right. 137 | omega. 138 | apply le_plus_left. 139 | remember (S n * fl_log (div2 n)) as x. 140 | omega. 141 | Qed. 142 | 143 | Theorem man_time'_nlogn: big_oh man_time' (fun n => n * fl_log n). 144 | Proof. 145 | apply (big_oh_trans man_time' 146 | (fun n => n * fl_log n + 3) 147 | (fun n => n * fl_log n)). 148 | exists 0. 149 | exists 23. 150 | intros n JUNK. 151 | apply (le_trans (man_time' n) 152 | (23 * n * fl_log n + 3) 153 | (23 * (n * fl_log n + 3))). 154 | apply man_time'_nlogn_help. 155 | rewrite mult_plus_distr_l. 156 | rewrite mult_assoc. 157 | apply le_plus_right. 158 | omega. 159 | apply nlogn_plus_3_is_n_log_n. 160 | Qed. 161 | -------------------------------------------------------------------------------- /make_array/make_array_nlogn1_fold.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad. 2 | Require Import Braun.insert.insert_log. 3 | Require Import Braun.fold.fold. 4 | 5 | Require Import Braun.common.sequence. 6 | 7 | Require Import Braun.common.braun. 8 | Require Import Braun.common.array. 9 | Require Import Braun.common.util Braun.common.big_oh. 10 | Require Import Braun.common.log Braun.common.le_util. 11 | Require Import Arith Arith.Even Arith.Div2 Omega. 12 | 13 | (* Foldr version of make_array_naive *) 14 | Section make_array_naive. 15 | Variable A : Set. 16 | 17 | Fixpoint man_time n : nat := 18 | match n with 19 | | 0 => 4 20 | | S n' => man_time n' + insert_time n' + 14 21 | end. 22 | 23 | Definition make_array_naive_result (b : @bin_tree A) (xs : list A) (c : nat) : Prop := 24 | let n := length xs in 25 | Braun b n 26 | /\ c = man_time n 27 | /\ SequenceR b xs. 28 | 29 | (* technically, we should count 4 more for the call to foldr, *) 30 | (* but that means that we cannot use make_array_naive_result *) 31 | (* as the loop invariant argument to foldr so we just skip it *) 32 | Program Definition make_array_naive l : 33 | {! b !:! @bin_tree A !! 34 | make_array_naive_result b l c !} := 35 | foldr make_array_naive_result 36 | (fun x y => x <- insert x y; +=4; <== x) 37 | bt_mt 38 | l. 39 | 40 | Next Obligation. 41 | Proof. 42 | clear am H2. 43 | rename H0 into IR. 44 | rename H1 into MC. 45 | 46 | unfold insert_result in IR. 47 | destruct MC as [BRy [ACCCeq SR]]. 48 | unfold make_array_naive_result. 49 | remember (IR (length xs) BRy) as IRlxs. 50 | destruct IRlxs as [BRx0 [SRimpl EQxn]]. 51 | simpl. 52 | repeat split;auto. 53 | omega. 54 | Qed. 55 | 56 | Next Obligation. 57 | Proof. 58 | unfold make_array_naive_result. 59 | repeat split; auto. 60 | Qed. 61 | 62 | Lemma man_time_helper: 63 | forall n, 64 | man_time n <= n * insert_time n + (n * 14) + 4. 65 | Proof. 66 | intros n. 67 | induction n as [|n]. 68 | simpl; omega. 69 | unfold man_time; fold man_time. 70 | apply (le_trans (man_time n + insert_time n + 14) 71 | ((n * insert_time n + n * 14 + 4) + insert_time n + 14) 72 | (S n * insert_time (S n) + S n * 14 + 4)); try omega. 73 | clear IHn. 74 | replace (S n * insert_time (S n)) with (n * insert_time (S n) + insert_time (S n)). 75 | 76 | assert (insert_time n <= insert_time (S n)) as ITLT. 77 | unfold insert_time. 78 | apply le_plus_left. 79 | apply le_mult_right. 80 | apply fl_log_monotone_Sn. 81 | 82 | assert (n * insert_time n <= n * insert_time (S n)) as NITLT. 83 | apply le_mult_right. 84 | assumption. 85 | 86 | omega. 87 | 88 | assert (S n = n+1) as SN;try omega. 89 | rewrite SN at 3; clear SN. 90 | rewrite mult_plus_distr_r. 91 | omega. 92 | Qed. 93 | 94 | Theorem man_time_nlogn : big_oh man_time (fun n => n * fl_log n). 95 | Proof. 96 | apply (big_oh_trans man_time 97 | (fun n => n * fl_log n + n + 10) 98 | (fun n => n * fl_log n)). 99 | exists 0. 100 | exists 20. 101 | intros n H; clear H. 102 | apply (le_trans (man_time n) 103 | (n * insert_time n + (n * 14) + 4) 104 | (20*(n * fl_log n + n + 10))). 105 | apply man_time_helper. 106 | unfold insert_time. 107 | repeat (rewrite mult_plus_distr_l). 108 | repeat (rewrite mult_assoc). 109 | replace (n * 9 * fl_log n) with (9 * n * fl_log n). 110 | replace (n * 6) with (6 * n); try (apply mult_comm). 111 | replace (n * 14) with (14 * n); try (apply mult_comm). 112 | replace (9 * n * fl_log n + 6 * n + 14 * n + 4) 113 | with (9 * n * fl_log n + 20 * n + 4); try omega. 114 | 115 | assert (9 * n * fl_log n <= 20 * n * fl_log n); try omega. 116 | apply le_mult_left. 117 | apply le_mult_left. 118 | omega. 119 | 120 | rewrite (mult_comm 9). 121 | reflexivity. 122 | 123 | apply (big_oh_trans (fun n => n * fl_log n + n + 10) 124 | (fun n => n * fl_log n + n) 125 | (fun n => n * fl_log n)). 126 | exists 1. 127 | exists 11. 128 | intros n L. 129 | destruct n; intuition. 130 | clear L. 131 | rewrite mult_plus_distr_l. 132 | 133 | assert ((S n * fl_log (S n)) <= 11 * (S n * fl_log (S n))); try omega. 134 | remember (mult_O_le (S n * fl_log (S n)) 11) as FACT. 135 | inversion FACT; intuition. 136 | 137 | apply big_oh_nlogn_plus_n__nlogn. 138 | Qed. 139 | 140 | End make_array_naive. 141 | -------------------------------------------------------------------------------- /make_array/make_array_nlogn1_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "../insert/insert_log_gen.rkt") 3 | (provide make_array_naive) 4 | 5 | (Fixpoint 6 | make_array_naive #:implicit @A{Set} @xs{list A} 7 | #:returns @{@"@"bin_tree A} 8 | (match (xs) 9 | [(nil) => (<== bt_mt)] 10 | [(cons x xs′) 11 | => 12 | (bind ([bt (make_array_naive xs′)]) 13 | (bind ([ir (insert x bt)]) 14 | (<== ir)))])) 15 | -------------------------------------------------------------------------------- /make_array/make_array_nlogn2.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad. 2 | 3 | Require Import Braun.common.sequence. 4 | Require Import Braun.common.list_util. 5 | 6 | Require Import Braun.common.braun. 7 | Require Import Braun.common.array. 8 | Require Import Braun.common.util. 9 | Require Import Braun.common.log. 10 | 11 | Require Import Braun.common.big_oh Braun.common.le_util Braun.common.util. 12 | 13 | Require Import Arith Arith.Even Arith.Div2 Omega. 14 | Require Import Program.Wf Init.Wf. 15 | 16 | Include WfExtensionality. 17 | 18 | Definition unravel_time len := 10 * len + 5. 19 | 20 | Definition unravel_result (A:Set) (xs:list A) (eo:list A * list A) (c:nat) := 21 | let (e, o) := eo in 22 | xs = interleave e o 23 | /\ length o <= length e <= length o + 1 24 | /\ c = unravel_time (length xs). 25 | 26 | Load "unravel_gen.v". 27 | 28 | Next Obligation. 29 | Proof. 30 | rewrite interleave_case2. 31 | split; auto. 32 | split. 33 | omega. 34 | unfold unravel_time. 35 | omega. 36 | Qed. 37 | 38 | Program Fixpoint make_array_td_time n {measure n} := 39 | match n with 40 | | 0 => 3 41 | | S n' => 42 | 10 * n' + 18 + 43 | make_array_td_time (div2 (n'+1)) + 44 | make_array_td_time (div2 n') 45 | end. 46 | 47 | Definition make_array_td_result (A:Set) xs (b:@bin_tree A) c := 48 | let n := length xs in 49 | Braun b n 50 | /\ c = make_array_td_time n 51 | /\ SequenceR b xs. 52 | 53 | Load "make_array_nlogn2_gen.v". 54 | 55 | Next Obligation. 56 | Proof. 57 | repeat split; auto. 58 | Qed. 59 | 60 | Next Obligation. 61 | Proof. 62 | clear make_array_td. 63 | rename H into UR. 64 | 65 | unfold unravel_result in UR. 66 | destruct UR. 67 | subst xs'. 68 | simpl. rewrite <- interleave_length_split. 69 | omega. 70 | Qed. 71 | 72 | Next Obligation. 73 | Proof. 74 | clear make_array_td. 75 | clear H am. 76 | rename H0 into UR. 77 | unfold unravel_result in UR. 78 | destruct UR. 79 | subst xs'. 80 | simpl. rewrite <- interleave_length_split. 81 | omega. 82 | Qed. 83 | 84 | Next Obligation. 85 | Proof. 86 | clear make_array_td. 87 | clear am H6. 88 | clear am1 H7. 89 | rename H0 into MATRevens. 90 | rename H1 into MATRodds. 91 | rename l into e. rename l0 into o. 92 | 93 | unfold unravel_result in *. 94 | unfold make_array_td_result in *. 95 | 96 | destruct MATRevens as [BRevens [ANeq SEQevens]]. 97 | destruct MATRodds as [BRodds [AN0eq SEQodds]]. 98 | 99 | simpl in *. 100 | rewrite <- interleave_length_split. 101 | split; [|split]. 102 | 103 | (* braun *) 104 | replace (S (length e + length o)) with (length e + length o + 1); try omega. 105 | eauto. 106 | 107 | (* running time *) 108 | remember (length e) as LE; clear HeqLE. 109 | remember (length o) as LO; clear HeqLO. 110 | subst an0 an. 111 | unfold unravel_time. 112 | assert (LE = LO \/ LE = LO + 1) as TWOCASES; try omega. 113 | destruct TWOCASES; subst LE; clear. 114 | unfold_sub make_array_td_time (make_array_td_time (S (LO+LO))). 115 | replace (div2 (LO+LO)) with LO; [|rewrite double_div2; reflexivity]. 116 | replace (div2 (LO+LO+1)) with LO. 117 | omega. 118 | rewrite <- (div2_with_odd_argument LO) at 1. 119 | replace (LO+LO+1) with (S (LO+LO)); omega. 120 | 121 | unfold_sub make_array_td_time (make_array_td_time (S (LO+1+LO))). 122 | replace (LO+1+LO+1) with ((LO+1)+(LO+1)); try omega. 123 | replace (div2 ((LO+1)+(LO+1))) with (LO+1);[|rewrite double_div2; reflexivity]. 124 | replace (div2 (LO+1+LO)) with LO. 125 | omega. 126 | rewrite <- (div2_with_odd_argument LO) at 1. 127 | replace (LO+1+LO) with (S (LO+LO)); omega. 128 | 129 | (* correctness *) 130 | eauto. 131 | Qed. 132 | 133 | Program Fixpoint make_array_td_time2 n {measure n} := 134 | match n with 135 | | 0 => 1 136 | | S n' => 137 | n' + 138 | make_array_td_time2 (div2 (n'+1)) + 139 | make_array_td_time2 (div2 n') 140 | end. 141 | 142 | Lemma make_array_td_time12 : big_oh make_array_td_time make_array_td_time2. 143 | Proof. 144 | exists 0. 145 | exists 28. 146 | intros n LT;clear LT. 147 | apply (well_founded_induction 148 | lt_wf 149 | (fun n => make_array_td_time n <= 28 * make_array_td_time2 n)). 150 | clear n; intros n IND. 151 | destruct n. 152 | compute. 153 | omega. 154 | unfold_sub make_array_td_time (make_array_td_time (S n)). 155 | unfold_sub make_array_td_time2 (make_array_td_time2 (S n)). 156 | rewrite mult_plus_distr_l. 157 | rewrite mult_plus_distr_l. 158 | destruct n. 159 | compute. 160 | omega. 161 | replace (10 * S n) with (10 + 10 * n); [|omega]. 162 | replace (28 * S n) with (28 + 28 * n); [|omega]. 163 | assert (make_array_td_time (div2 (S n + 1)) <= 164 | 28 * make_array_td_time2 (div2 (S n + 1))). 165 | apply IND; auto. 166 | assert (make_array_td_time (div2 (S n)) <= 167 | 28 * make_array_td_time2 (div2 (S n))). 168 | apply IND; auto. 169 | omega. 170 | Qed. 171 | 172 | Lemma make_array_td_time2_mat_time : big_oh make_array_td_time2 mat_time. 173 | Proof. 174 | exists 1. 175 | exists 2. 176 | intros n LT. 177 | destruct n;intuition. 178 | clear LT. 179 | apply (well_founded_induction 180 | lt_wf 181 | (fun n => make_array_td_time2 (S n) <= 2 * mat_time (S n))). 182 | clear n; intros n IND. 183 | destruct n. 184 | compute. 185 | omega. 186 | rewrite mat_time_Sn. 187 | rewrite mult_plus_distr_l. 188 | rewrite mult_plus_distr_l. 189 | 190 | replace (make_array_td_time2 (S (S n))) 191 | with ((S n) + make_array_td_time2 (div2 ((S n)+1)) + 192 | make_array_td_time2 (div2 (S n))). 193 | replace (S n + 1) with (S (S n)); [|omega]. 194 | destruct n. 195 | compute. 196 | omega. 197 | replace (div2 (S (S (S n)))) with (S (div2 (S n)));[|simpl;omega]. 198 | replace (div2 (S (S n))) with (S (div2 n));[|simpl;omega]. 199 | 200 | assert (make_array_td_time2 (S (div2 (S n))) <= 2 * mat_time (S (div2 (S n)))). 201 | apply IND;auto. 202 | assert (make_array_td_time2 (S (div2 n)) <= 2 * mat_time (S (div2 n))). 203 | apply IND. 204 | apply (lt_trans (div2 n) (S n) (S (S n)));auto. 205 | omega. 206 | 207 | unfold_sub make_array_td_time2 (make_array_td_time2 (S (S n))). 208 | unfold div2. 209 | reflexivity. 210 | Qed. 211 | 212 | Theorem make_array_td_nlogn : big_oh make_array_td_time (fun n => n*cl_log n). 213 | Proof. 214 | apply (big_oh_trans make_array_td_time mat_time (fun n => n*cl_log n)). 215 | apply (big_oh_trans make_array_td_time make_array_td_time2 mat_time). 216 | apply make_array_td_time12. 217 | apply make_array_td_time2_mat_time. 218 | apply mat_time_nlogn. 219 | Qed. 220 | -------------------------------------------------------------------------------- /make_array/make_array_nlogn2_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "unravel_gen.rkt") 3 | (provide make_array_td) 4 | 5 | (Fixpoint 6 | make_array_td #:implicit @A{Set} @xs{list A} 7 | #:measure "(length xs)" 8 | #:returns @{@"@"bin_tree A} 9 | (match (xs) 10 | [(nil) => (<== bt_mt)] 11 | [(cons x xs′) 12 | => 13 | (bind ([eo (unravel xs′)]) 14 | (match (eo) 15 | [(pair odds evens) 16 | => 17 | (bind ([odds_bt (make_array_td odds)]) 18 | (bind ([evens_bt (make_array_td evens)]) 19 | (<== (bt_node x odds_bt evens_bt))))]))])) 20 | -------------------------------------------------------------------------------- /make_array/pad_drop_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide pad_drop) 3 | (Fixpoint 4 | pad_drop #:implicit @A{Set} @k{nat} @xs{list A} @x{A} 5 | #:returns @{list A} 6 | (match (k) 7 | [0 => (<== nil)] 8 | [(S k′) 9 | => 10 | (match (xs) 11 | [(nil) 12 | => 13 | (bind ([rst (pad_drop k′ nil x)]) 14 | (<== (cons x rst)))] 15 | [(cons hd tl) 16 | => 17 | (bind ([rst (pad_drop k′ tl x)]) 18 | (<== (cons hd rst)))])])) 19 | -------------------------------------------------------------------------------- /make_array/rows1_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "rows_gen.rkt") 3 | (provide rows1) 4 | 5 | (Fixpoint 6 | rows1 #:implicit @A{Set} @xs{list A} 7 | #:returns @{list (nat * (list A))} 8 | (bind ((res (rows 1 xs))) 9 | (<== res))) 10 | -------------------------------------------------------------------------------- /make_array/rows_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "drop_gen.rkt" "take_gen.rkt") 3 | (provide rows) 4 | 5 | (Fixpoint 6 | rows #:implicit @A{Set} @k{nat} @xs{list A} 7 | #:measure "(length xs)" 8 | #:returns @{list (nat * (list A))} 9 | (match (k) 10 | [0 => (<== nil)] 11 | [(S _) 12 | => 13 | (match (xs) 14 | [(nil) => (<== nil)] 15 | [(cons _ _) 16 | => 17 | (bind ([taken (take k xs)]) 18 | (bind ([dropped (drop k xs)]) 19 | (bind ([rst (rows (* 2 k) dropped)]) 20 | (<== (cons (pair k taken) rst)))))])])) 21 | -------------------------------------------------------------------------------- /make_array/split_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide split) 3 | (require "take_gen.rkt" "drop_gen.rkt") 4 | (Fixpoint 5 | split #:implicit @A{Set} @k{nat} @xs{list A} 6 | #:returns @{list A * list A} 7 | (bind ((taken (take k xs))) 8 | (bind ((dropped (drop k xs))) 9 | (<== (pair taken dropped))))) 10 | -------------------------------------------------------------------------------- /make_array/take_drop_split.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.util Braun.common.le_util. 2 | Require Import Braun.common.big_oh. 3 | Require Import Arith Arith.Le Arith.Lt Peano Arith.Min. 4 | Require Import Coq.Arith.Compare_dec. 5 | Require Import Program.Wf Init.Wf. 6 | 7 | Include WfExtensionality. 8 | 9 | Definition take_time n len := 10 | if le_lt_dec len n 11 | then 10 * len + 3 12 | else 10 * n + 5. 13 | 14 | Definition take_result (A:Set) n (xs:list A) (res:list A) c := 15 | c = take_time n (length xs) /\ 16 | ((length xs) < n -> length res = (length xs)) /\ 17 | (n <= (length xs) -> length res = n). 18 | 19 | Load "take_gen.v". 20 | 21 | Next Obligation. 22 | Proof. 23 | unfold take_result. 24 | simpl. 25 | split; [|split;omega]. 26 | unfold take_time. 27 | dispatch_if REL REL'. 28 | omega. 29 | simpl in REL'. 30 | inversion REL'. 31 | Qed. 32 | 33 | Next Obligation. 34 | Proof. 35 | unfold take_result. 36 | simpl. 37 | split. 38 | unfold take_time. 39 | dispatch_if REL REL'. 40 | inversion REL. 41 | omega. 42 | split; intros; omega. 43 | Qed. 44 | 45 | Next Obligation. 46 | Proof. 47 | clear am H1. 48 | rename H0 into RC. 49 | 50 | unfold take_result in *. 51 | unfold take_time in *. 52 | destruct RC as [ANeq [SHORT LONG]]. 53 | 54 | split. 55 | 56 | subst an. 57 | dispatch_if COND1 COND1'; dispatch_if COND2 COND2'. 58 | simpl; omega. 59 | simpl in COND2'; omega. 60 | simpl in COND2. 61 | apply le_S_n in COND2. 62 | omega. 63 | omega. 64 | 65 | simpl. 66 | 67 | split; intros LT; omega. 68 | Qed. 69 | 70 | Lemma take_linear : forall len, big_oh (fun n => take_time n len) (fun n => n). 71 | Proof. 72 | intros len. 73 | exists 1. 74 | exists 15. 75 | intros n LT. 76 | destruct n; intuition. 77 | clear LT. 78 | unfold take_time. 79 | dispatch_if COND COND'; omega. 80 | Qed. 81 | 82 | Definition drop_time n len := 83 | if le_lt_dec n len 84 | then 8 * n + 3 85 | else 8 * len + 5. 86 | 87 | Definition drop_result (A:Set) n (xs:list A) (res:list A) c := 88 | c = drop_time n (length xs) /\ 89 | ((length xs) < n -> length res = 0) /\ 90 | (n <= (length xs) -> length res = (length xs) - n). 91 | 92 | Load "drop_gen.v". 93 | 94 | Next Obligation. 95 | Proof. 96 | unfold drop_result. 97 | split. 98 | unfold drop_time. 99 | dispatch_if COND COND'; omega. 100 | 101 | split; intros REL. 102 | inversion REL. 103 | omega. 104 | Qed. 105 | 106 | Next Obligation. 107 | Proof. 108 | unfold drop_result. 109 | split. 110 | simpl. 111 | unfold drop_time. 112 | dispatch_if COND COND'; omega. 113 | 114 | split; intros REL. 115 | simpl. 116 | omega. 117 | simpl in REL. 118 | inversion REL. 119 | Qed. 120 | 121 | Next Obligation. 122 | Proof. 123 | clear am H1. 124 | rename H0 into RC. 125 | 126 | unfold drop_result in *. 127 | destruct RC as [ANEQ [SHORT LONG]]. 128 | 129 | split. 130 | subst an. 131 | simpl. 132 | unfold drop_time. 133 | dispatch_if COND COND'; dispatch_if COND2 COND2'; omega. 134 | 135 | split; intros REL. 136 | simpl in REL. 137 | apply lt_S_n in REL. 138 | apply SHORT in REL. 139 | omega. 140 | 141 | simpl in REL. 142 | apply le_S_n in REL. 143 | apply LONG in REL. 144 | simpl; omega. 145 | Qed. 146 | 147 | Lemma drop_linear : forall len, big_oh (fun n => drop_time n len) (fun n => n). 148 | Proof. 149 | intros len. 150 | exists 1. 151 | exists 11. 152 | intros n LT. 153 | destruct n; intuition. 154 | clear LT. 155 | unfold drop_time. 156 | dispatch_if COND COND'; omega. 157 | Qed. 158 | 159 | Definition split_time len k := 160 | take_time k len + drop_time k len + 9. 161 | 162 | Definition split_result (A:Set) (k:nat) (xs:list A) (res:list A * list A) c := 163 | c = split_time (length xs) k /\ 164 | ((length xs) < k -> length (fst res) = (length xs) /\ length (snd res) = 0) /\ 165 | (k <= (length xs) -> 166 | length (fst res) = k /\ 167 | length (snd res) = (length xs) - k). 168 | 169 | Load "split_gen.v". 170 | 171 | Next Obligation. 172 | Proof. 173 | clear H3 am H2 am0. 174 | rename H0 into DR. 175 | rename H1 into TR. 176 | 177 | unfold take_result in *. 178 | unfold drop_result in *. 179 | unfold split_result. 180 | unfold split_time. 181 | 182 | split. 183 | omega. 184 | simpl. 185 | destruct TR. destruct DR. 186 | split; intros; split; intuition. 187 | Qed. 188 | 189 | Lemma split_time_linear : forall len, big_oh (fun n => split_time len n) (fun n => n). 190 | Proof. 191 | intros len. 192 | unfold split_time. 193 | apply big_oh_plus. 194 | apply big_oh_plus. 195 | apply take_linear. 196 | apply drop_linear. 197 | exists 1. 198 | exists 10. 199 | intros; omega. 200 | Qed. 201 | 202 | Definition pad_drop_time k := k * 11 + 3. 203 | Hint Unfold pad_drop_time. 204 | 205 | Definition pad_drop_result (A:Set) k (xs : list A) (x:A) (res : list A) c := 206 | c = pad_drop_time k /\ length res = k. 207 | Hint Unfold pad_drop_result. 208 | 209 | Load "pad_drop_gen.v". 210 | 211 | Next Obligation. 212 | Proof. 213 | clear am H1. 214 | rename H0 into PDRnil. 215 | 216 | unfold pad_drop_result in *. 217 | unfold pad_drop_time in *. 218 | destruct PDRnil as [ANeq LReq]. 219 | split; simpl; omega. 220 | Qed. 221 | 222 | Next Obligation. 223 | Proof. 224 | clear am H1. 225 | rename H0 into PDRrst. 226 | unfold pad_drop_result in *. 227 | unfold pad_drop_time in *. 228 | destruct PDRrst. 229 | split; auto; simpl; omega. 230 | Qed. 231 | 232 | Lemma pad_drop_linear : big_oh pad_drop_time (fun n => n). 233 | Proof. 234 | apply big_oh_plus; auto. 235 | Qed. 236 | -------------------------------------------------------------------------------- /make_array/take_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide take) 3 | 4 | (Fixpoint 5 | take #:implicit @A{Set} @n{nat} @xs{list A} 6 | #:returns @{list A} 7 | (match (xs) 8 | [(nil) => (<== nil)] 9 | [(cons x xs) 10 | => 11 | (match (n) 12 | [0 => (<== nil)] 13 | [(S n′) => 14 | (bind ([rst (take n′ xs)]) 15 | (<== (cons x rst)))])])) 16 | -------------------------------------------------------------------------------- /make_array/unravel_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide unravel) 4 | 5 | (Fixpoint 6 | unravel #:implicit @A{Set} @xs{list A} 7 | #:returns @{list A * list A} 8 | (match (xs) 9 | [(nil) => (<== (pair nil nil))] 10 | [(cons x xs′) 11 | => 12 | (bind ([odds_evens (unravel xs′)]) 13 | (match (odds_evens) 14 | [(pair odds evens) 15 | => 16 | (<== (pair (cons x evens) odds))]))])) 17 | -------------------------------------------------------------------------------- /make_array/zip_with_3_bt_node_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide zip_with_3_bt_node) 3 | 4 | (Fixpoint 5 | zip_with_3_bt_node 6 | #:implicit @A{Set} 7 | @xs{list A} 8 | @ts1{list (@"@"bin_tree A)} 9 | @ts2{list (@"@"bin_tree A)} 10 | #:returns @{list (@"@"bin_tree A)} 11 | (match (xs) 12 | [(nil) => (<== nil)] 13 | [(cons x xs′) 14 | => 15 | (match (ts1) 16 | [(nil) => (<== nil)] 17 | [(cons t1 ts1′) 18 | => 19 | (match (ts2) 20 | [(nil) => (<== nil)] 21 | [(cons t2 ts2′) 22 | => 23 | (bind ([rest (zip_with_3_bt_node xs′ ts1′ ts2′)]) 24 | (<== (cons (bt_node x t1 t2) 25 | rest)))])])])) 26 | -------------------------------------------------------------------------------- /monad/laws.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad. 2 | Require Import ProofIrrelevance. 3 | 4 | Definition join (A:Set) (PA:A -> nat -> Prop) 5 | (PB:(C A PA) -> nat -> Prop) 6 | (amm:C (C A PA) PB) 7 | : C A PA. 8 | Proof. 9 | destruct amm as [am pam]. 10 | destruct am as [a pa]. 11 | exists a. 12 | exact pa. 13 | Qed. 14 | 15 | Definition sig_eqv A (P1:A -> Prop) (P2:A -> Prop) (s1:sig P1) (s2:sig P2) : Prop := 16 | let v1 := (proj1_sig s1) in 17 | let v2 := (proj1_sig s2) in 18 | v1 = v2 /\ (P1 v1 <-> P2 v2). 19 | 20 | Theorem left_identity: 21 | forall A B PA PB x PAx yf, 22 | sig_eqv _ _ _ 23 | (bind A PA B PB (ret A PA x PAx) yf) 24 | (yf x (ex_intro (PA x) 0 PAx)). 25 | Proof. 26 | intros A B PA PB x PAx yf. 27 | unfold sig_eqv. unfold bind. unfold ret. simpl. 28 | remember (yf x (ex_intro (PA x) 0 PAx)) as y. 29 | destruct y as [y [yn Py]]. simpl in *. 30 | split. auto. 31 | split. 32 | 33 | intros. exists yn. auto. 34 | 35 | intros [bn BIND]. exists (0 + bn). auto. 36 | Qed. 37 | 38 | Require Import Omega. 39 | 40 | Lemma right_identity_helper: 41 | forall (A:Set) (PA:A -> nat -> Prop) (a:A), 42 | (exists n, PA a n) -> 43 | (forall xn, PA a xn -> PA a (xn + 0)). 44 | Proof. 45 | intros A PA x. 46 | intros [n PAx]. 47 | intros xn H. 48 | replace (xn + 0) with xn; try omega. 49 | auto. 50 | Qed. 51 | 52 | Theorem right_identity: 53 | forall A PA m, 54 | sig_eqv _ _ _ 55 | (bind A PA A PA m 56 | (fun a1 pa => 57 | ret A 58 | (fun a2 an => 59 | forall xn : nat, 60 | PA a1 xn -> 61 | PA a2 (xn + an)) 62 | a1 63 | (right_identity_helper A PA a1 pa))) 64 | m. 65 | Proof. 66 | intros A PA m. 67 | unfold sig_eqv, bind, ret. simpl. 68 | destruct m as [a [an pa]]. simpl. 69 | intuition. 70 | Qed. 71 | 72 | Lemma assoc_helper1: 73 | forall (A B : Set) (PA : A -> nat -> Prop) (PB : B -> nat -> Prop), 74 | (forall x : A, 75 | (exists an : nat, PA x an) -> 76 | forall x1 : B, 77 | (exists an : nat, 78 | (fun (b : B) (bn : nat) => 79 | forall an0 : nat, PA x an0 -> PB b (an0 + bn)) x1 an) -> 80 | (fun a : B => exists an : nat, PB a an) x1). 81 | Proof. 82 | intros A B PA PB a [an pa] b [an' PAB]. 83 | apply PAB in pa. 84 | eauto. 85 | Defined. 86 | 87 | Lemma assoc_helper2: 88 | forall (A B G : Set) (PA : A -> nat -> Prop) (PB : B -> nat -> Prop) (PG : G -> nat -> Prop), 89 | forall x : A, 90 | (exists an : nat, PA x an) -> 91 | forall x1 : B, 92 | (exists an : nat, 93 | (fun (b : B) (bn : nat) => 94 | forall an0 : nat, PA x an0 -> PB b (an0 + bn)) x1 an) -> 95 | (forall g gn anbn, 96 | PB x1 anbn -> 97 | PG g (anbn + gn)) -> 98 | forall x3 : G, 99 | (exists an : nat, PG x3 an) -> 100 | (fun a : G => 101 | exists an : nat, 102 | (fun (b : G) (bn : nat) => 103 | forall an0 : nat, PA x an0 -> PG b (an0 + bn)) a an) x3. 104 | Proof. 105 | intros A B G PA PB PG a [an pa] b [bn pb] pbg g [gn pg]. 106 | exists (an + bn). 107 | intros an' pa'. 108 | apply pb in pa'. 109 | replace (an' + (an + bn)) with ((an' + bn) + an); try omega. 110 | eapply pbg. 111 | apply pa'. 112 | Qed. 113 | 114 | Theorem associativity: 115 | forall 116 | (A:Set) 117 | (B:Set) 118 | (G:Set) 119 | (PA:A -> nat -> Prop) 120 | (PB:B -> nat -> Prop) 121 | (PG:G -> nat -> Prop) 122 | (ma:C A PA) 123 | (fb:forall (a:A) (pa:exists an, PA a an), 124 | C B 125 | (fun b bn => 126 | forall an : nat, 127 | PA a an -> 128 | PB b (an + bn))) 129 | (gg:forall (b:B) (pb:exists bn, PB b bn), 130 | C G 131 | (fun g gn => 132 | forall anbn : nat, 133 | PB b anbn -> 134 | PG g (anbn + gn))) 135 | ggp, 136 | sig_eqv G _ _ 137 | (bind B PB G PG 138 | (bind A PA B PB 139 | ma 140 | fb) 141 | gg) 142 | (bind A PA G PG 143 | ma 144 | (fun (a:A) (pa:exists an, PA a an) => 145 | let (b, pbe) := (fb a pa) in 146 | let mb' := exist _ b (assoc_helper1 A B PA PB a pa b pbe) in 147 | let (_, pbe') := mb' in 148 | let (g, pge) := bind B PB G PG mb' gg in 149 | let mg' := exist _ g (assoc_helper2 A B G PA PB PG a pa b pbe (ggp b) g pge) in 150 | mg')). 151 | Proof. 152 | intros. 153 | 154 | destruct ma as [a [an pa]]. 155 | remember (ex_intro (fun n : nat => PA a n) an pa) as pae. 156 | simpl. 157 | remember (assoc_helper1 A B PA PB a pae) as helper1'. 158 | remember (assoc_helper2 A B G PA PB PG a pae) as helper2'. 159 | clear Heqhelper1' Heqhelper2'. 160 | rename helper1' into helper1. 161 | rename helper2' into helper2. 162 | 163 | remember (fb a pae) as mb. 164 | rewrite Heqpae. 165 | destruct mb as [b [bn pb]]. 166 | clear Heqpae pae Heqmb. 167 | 168 | remember (ex_intro (fun an0 : nat => PB b an0) (an + bn) (pb an pa)) as pbe. 169 | remember (ex_intro 170 | (fun an0 : nat => 171 | forall an1 : nat, PA a an1 -> PB b (an1 + an0)) bn 172 | pb) as pbe'. 173 | simpl. 174 | remember (helper1 b pbe') as helper1'. 175 | remember (helper2 b pbe') as helper2'. 176 | clear helper1 helper2 Heqhelper1' Heqhelper2'. 177 | simpl in helper1'. rename helper1' into pbe''. 178 | 179 | replace pbe'' with pbe. 180 | remember (gg b pbe) as mg. 181 | rewrite Heqpbe. 182 | destruct mg as [g [gn pg]]. 183 | 184 | unfold sig_eqv. simpl. intuition. 185 | 186 | apply proof_irrelevance. 187 | Qed. 188 | -------------------------------------------------------------------------------- /monad/monad.v: -------------------------------------------------------------------------------- 1 | (* START: C *) 2 | Definition C (A:Set) (P:A -> nat -> Prop) : Set := 3 | {a : A | exists (an:nat), (P a an)}. 4 | (* STOP: C *) 5 | Hint Unfold C. 6 | 7 | (* START: ret *) 8 | Definition ret (A:Set) (P:A -> nat -> Prop) (a:A) (Pa0:P a 0) : C A P. 9 | (* STOP: ret *) 10 | Proof. 11 | exists a. 12 | exists 0. 13 | apply Pa0. 14 | Defined. 15 | 16 | (* START: bind *) 17 | Definition bind (A:Set) (PA:A -> nat -> Prop) 18 | (B:Set) (PB:B -> nat -> Prop) 19 | (am:C A PA) 20 | (bf:forall (a:A) (pa:exists an, PA a an), 21 | C B (fun b bn => forall an, PA a an -> PB b (an+bn))) 22 | : C B PB. 23 | (* STOP: bind *) 24 | Proof. 25 | destruct am as [a Pa]. 26 | edestruct (bf a Pa) as [b Pb]. 27 | exists b. 28 | destruct Pa as [an Pa]. 29 | destruct Pb as [bn Pb]. 30 | exists (an + bn). 31 | eapply Pb. 32 | apply Pa. 33 | Defined. 34 | 35 | (* START: inc *) 36 | Definition inc (A:Set) k (PA : A -> nat -> Prop) 37 | (xc:C A (fun x xn => forall xm, xn + k = xm -> PA x xm)) 38 | : C A PA. 39 | (* STOP: inc *) 40 | Proof. 41 | destruct xc as [x Px]. 42 | exists x. 43 | destruct Px as [n Px]. 44 | exists (n + k). 45 | apply Px. 46 | reflexivity. 47 | Defined. 48 | 49 | Notation "<== x" := (ret _ _ x _) (at level 55). 50 | Notation "+= k ; c" := (inc _ k _ c) (at level 30, right associativity). 51 | Notation "x <- y ; z" := (bind _ _ _ _ y (fun (x : _) (am : _) => z) ) 52 | (at level 30, right associativity). 53 | Notation "x >>= y" := (bind _ _ _ _ x y) (at level 55). 54 | Notation "x >> y" := (bind _ _ _ _ x (fun _ => y)) (at level 30, right associativity). 55 | 56 | Notation "{! x !:! A !! P !}" := (C A (fun (x:A) (c:nat) => P)) (at level 55). 57 | 58 | -------------------------------------------------------------------------------- /monad/smonad.v: -------------------------------------------------------------------------------- 1 | Require Import Program. 2 | Require Import Omega. 3 | Require Import List. 4 | Require Import Braun.common.util. 5 | 6 | (* this is the type of things in the store *) 7 | Definition Q := (list nat * list nat)%type. 8 | 9 | (* this is the state type, a finite map from *) 10 | (* addresses to pairs of two lists of *) 11 | (* integers, ie our queue's internal state *) 12 | Definition ST := ((nat -> Q) * nat)%type. 13 | 14 | Definition STeq (st st':ST) := 15 | (snd st) = (snd st') /\ 16 | forall n, ((fst st) n) = ((fst st') n). 17 | 18 | Definition CS 19 | (A:Set) 20 | (Pre : ST -> Prop) 21 | (Post: A -> ST -> ST -> nat -> Prop) : Set := 22 | forall st:ST, 23 | Pre st -> 24 | {(a,st') : A * ST | exists an, 25 | Post a st st' an}. 26 | Hint Unfold CS. 27 | 28 | Definition ret (A:Set) (a:A) 29 | : CS A 30 | (fun st => True) 31 | (fun a' st st' time => st=st' /\ a=a' /\ time = 0). 32 | Proof. 33 | intros st _. 34 | exists (a,st). 35 | exists 0. 36 | auto. 37 | Defined. 38 | 39 | (* START: bind *) 40 | Definition bind 41 | (A:Set) (B:Set) 42 | (A_Pre:ST -> Prop) 43 | (A_Post:A -> ST -> ST -> nat -> Prop) 44 | (B_Pre:A -> ST -> Prop) 45 | (B_Post:A -> B -> ST -> ST -> nat -> Prop) 46 | (A_impl_B_Pre: 47 | forall st0, 48 | A_Pre st0 -> 49 | forall a st1 an, 50 | A_Post a st0 st1 an -> 51 | B_Pre a st1) 52 | (am:CS A A_Pre A_Post) 53 | (bf:forall (a:A), CS B (B_Pre a) (B_Post a)) 54 | : CS B A_Pre 55 | (fun b st0 st2 n => exists a st1 an bn, 56 | A_Post a st0 st1 an /\ 57 | B_Post a b st1 st2 bn /\ 58 | n = an+bn). 59 | (* STOP: bind *) 60 | Proof. 61 | intros st0 APRE. 62 | destruct (am st0 APRE) as [[a st1] A_PROP]; clear am. 63 | destruct (bf a st1) as [[b st2] B_PROP]. 64 | destruct A_PROP as [an A_POST]. 65 | apply (A_impl_B_Pre st0 APRE a st1 an A_POST). 66 | exists (b,st2). 67 | destruct A_PROP as [an A_POST]. 68 | destruct B_PROP as [bn B_POST]. 69 | exists (an+bn) a st1. 70 | exists an bn. 71 | repeat split; assumption. 72 | Defined. 73 | 74 | Definition inc 75 | (A:Set) 76 | k 77 | (Pre:ST -> Prop) 78 | (Post:A -> ST -> ST -> nat -> Prop) 79 | (C : CS A Pre 80 | (fun a st0 st1 an => 81 | forall am, 82 | an + k = am -> 83 | Post a st0 st1 am)) 84 | : CS A Pre Post. 85 | Proof. 86 | intros st PRE. 87 | destruct (C st PRE) as [[a st'] P]. 88 | exists (a,st'). 89 | destruct P as [an IMPL_POST]. 90 | exists (an+k). 91 | auto. 92 | Defined. 93 | 94 | Definition get : 95 | forall addr, 96 | CS Q 97 | (fun st => True) 98 | (fun q st_pre st_post time => 99 | time = 0 /\ ((fst st_post) addr) = q /\ st_pre = st_post). 100 | Proof. 101 | intros addr [fm high_addr] _. 102 | exists (fm addr,(fm,high_addr)). 103 | exists 0. 104 | repeat split; reflexivity. 105 | Defined. 106 | 107 | Definition set: 108 | forall addr nv, 109 | CS () 110 | (fun st => True) 111 | (fun i st_pre st_post time => 112 | time = 0 /\ 113 | (snd st_pre) = (snd st_post) /\ 114 | ((fst st_post) addr) = nv /\ 115 | forall addr', 116 | (addr <> addr') -> 117 | ((fst st_post) addr') = ((fst st_pre) addr')). 118 | Proof. 119 | intros addr nv [fm high_addr] _. 120 | exists (tt,(fun addr' => if (eq_nat_dec addr addr') then nv else (fm addr'),high_addr)). 121 | exists 0. 122 | simpl. 123 | repeat split. 124 | destruct (eq_nat_dec addr addr);intuition. 125 | intros addr' NEQ. 126 | destruct (eq_nat_dec addr addr');intuition. 127 | Defined. 128 | 129 | Definition alloc : 130 | CS nat 131 | (fun st => True) 132 | (fun res st_pre st_post time => 133 | time = 0 /\ 134 | res = (snd st_pre) /\ 135 | (snd st_post) = (snd st_pre)+1). 136 | Proof. 137 | intros [fm high_addr] _. 138 | exists (high_addr,(fm,high_addr+1)). 139 | exists 0. 140 | repeat split; reflexivity. 141 | Defined. 142 | 143 | (* all allocated values are initialized as a pair of empty lists *) 144 | Definition init_st : ST := (fun n => (nil,nil),0). 145 | 146 | Definition run {A : Set} (Pre : ST -> Prop) Post : (Pre init_st) -> CS A Pre Post -> A. 147 | Proof. 148 | intros PRE Computation. 149 | destruct (Computation init_st) as [[a _] _]. 150 | apply PRE. 151 | apply a. 152 | Defined. 153 | 154 | Notation "<== x" := (ret _ x) (at level 55). 155 | Notation "+= k ; c" := (inc _ k _ _ _ _ c) (at level 30, right associativity). 156 | Notation "x <- y ; z" := (bind _ _ _ _ _ _ _ y (fun (x : _) => z) ) 157 | (at level 30, right associativity). 158 | Notation "! x" := (get x) (at level 55). 159 | Notation "x ::== y ; z" := (bind _ _ _ _ _ _ _ (set x y) (fun _ => z)) 160 | (at level 30, right associativity). 161 | -------------------------------------------------------------------------------- /paper/.gitignore: -------------------------------------------------------------------------------- 1 | /paper.tex 2 | -------------------------------------------------------------------------------- /paper/TODO.org: -------------------------------------------------------------------------------- 1 | * TODO Think about how to clarify time vs instruction counts 2 | [[../flops2015-reviews.txt::106]] 3 | * TODO Attempt to clarify monadic properties 4 | [[../flops2015-reviews.txt::169]] 5 | 6 | 7 | -------------------------------------------------------------------------------- /paper/binds.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad. 2 | 3 | (* START: bind1 *) 4 | Definition bind1 (A:Set) (PA:A -> nat -> Prop) 5 | (B:Set) (PB:B -> nat -> Prop) 6 | (am:C A PA) (bf:A -> C B PB) 7 | : C B PB. 8 | (* STOP: bind1 *) 9 | Abort. 10 | 11 | (* START: bind2 *) 12 | Definition bind2 (A:Set) (PA:A -> nat -> Prop) 13 | (B:Set) (PB:B -> nat -> Prop) 14 | (am:C A PA) 15 | (bf:A -> C B (fun b bn => forall an, PB b (bn+an))) 16 | : C B PB. 17 | (* STOP: bind2 *) 18 | Abort. 19 | 20 | (* START: bind3 *) 21 | Definition bind3 (A:Set) (PA:A -> nat -> Prop) 22 | (B:Set) (PB:B -> nat -> Prop) 23 | (am:C A PA) 24 | (bf:forall (a:A), 25 | C B (fun b bn => forall an, PA a an -> PB b (bn+an))) 26 | : C B PB. 27 | (* STOP: bind3 *) 28 | Abort. 29 | -------------------------------------------------------------------------------- /paper/extract-insert.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/base 2 | 3 | @(require "util.rkt" scriblib/footnote) 4 | 5 | @title[#:tag "sec:extract-insert"]{Extracting the @tt{insert} Function} 6 | 7 | One of the important benefits of our library is that 8 | none of the correctness conditions and running time 9 | infrastructure affect Coq's extraction process. 10 | In particular, our monad extracts as the identity 11 | monad, which means that the OCaml code produced by Coq 12 | does not require any modifications. 13 | For example, here is how @tt{insert} extracts: 14 | @inline-code{ 15 | type 'a bin_tree = | Bt_mt 16 | | Bt_node of 'a * 'a bin_tree * 'a bin_tree 17 | 18 | let rec insert i = function 19 | | Bt_mt -> Bt_node (i, Bt_mt, Bt_mt) 20 | | Bt_node (j, s, t) -> Bt_node (i, (insert j t), s) 21 | } 22 | The only declarations we added to 23 | aid Coq's extraction was the suggestion that it should 24 | inline the monad operations. And since the extracted 25 | version of our monad is the identity monad, the monad 26 | operations simply evaporate when they are inlined. 27 | 28 | More importantly, however, note that this code does not 29 | have any proof residue; there are no extra data-structures 30 | or function arguments or other artifacts of the information 31 | used to prove the running time correct. 32 | 33 | -------------------------------------------------------------------------------- /paper/extract.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/contract) 3 | 4 | (provide 5 | (contract-out 6 | [extract (-> path-string? 7 | (or/c string? 8 | (-> (listof string?) (listof string?))) 9 | (listof string?))])) 10 | 11 | (define (extract fn tag-or-fun) 12 | (call-with-input-file fn 13 | (λ (port) 14 | (define lines 15 | (cond 16 | [(string? tag-or-fun) 17 | (let loop () 18 | (define l (read-line port)) 19 | (cond 20 | [(eof-object? l) 21 | (error 'extract "didn't find start ~a tag in ~a" tag-or-fun fn)] 22 | [(matches-start? tag-or-fun l) 23 | (void)] 24 | [else (loop)])) 25 | (let loop () 26 | (define l (read-line port)) 27 | (cond 28 | [(eof-object? l) 29 | (error 'extract "didn't find end ~a tag in ~a" tag-or-fun fn)] 30 | [(matches-end? tag-or-fun l) 31 | '()] 32 | [else (cons l (loop))]))] 33 | [else 34 | (tag-or-fun 35 | (for/list ([l (in-lines port)]) 36 | l))])) 37 | (define prefix-len 38 | (for/fold ([s #f]) ([l (in-list lines)]) 39 | (define prefix (string-length (car (regexp-match #rx"^ *" l)))) 40 | (if s 41 | (min s prefix) 42 | prefix))) 43 | (and prefix-len 44 | (for/list ([l (in-list lines)]) 45 | (string-append (substring l prefix-len (string-length l)) 46 | "\n")))))) 47 | 48 | (define (matches-start? tag line) 49 | (define m (regexp-match #rx" *[(] *[*] *START: +([^ ]*)" line)) 50 | (and m (equal? (cadr m) tag))) 51 | 52 | (define (matches-end? tag line) 53 | (define m (regexp-match #rx" *[(] *[*] *STOP: +([^ ]*)" line)) 54 | (and m (equal? (cadr m) tag))) 55 | -------------------------------------------------------------------------------- /paper/paper.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/rfindler/395-2013/afaeb6f4076a1330bbdeb4537417906bbfab5119/paper/paper.pdf -------------------------------------------------------------------------------- /paper/paper.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/elsarticle 2 | 3 | @(require "util.rkt" "cite.rkt" 4 | scriblib/footnote 5 | scribble/core 6 | scribble/latex-properties 7 | racket/date) 8 | 9 | @title[#:style (style #f (list (tex-addition extra-tex-code)))]{ 10 | A Coq Library For Internal Verification of Running-Times 11 | } 12 | 13 | @;@doi{@hspace[4] @bold{Draft as of @(date->string (seconds->date (current-seconds)))}} 14 | 15 | @frontmatter[ 16 | #:authors 17 | (list @author{Jay McCarthy} 18 | @email["jay.mccarthy@gmail.com"] 19 | @address["University of Massachusetts at Lowell"] 20 | @author{Burke Fetscher} 21 | @email["burke.fetscher@eecs.northwestern.edu"] 22 | @author{Max S. New} 23 | @email["max.new@eecs.northwestern.edu"] 24 | @author{Daniel Feltey} 25 | @email["daniel.feltey@eecs.northwestern.edu"] 26 | @author{Robert Bruce Findler} 27 | @email["robby@eecs.northwestern.edu"] 28 | @address["Northwestern University"]) 29 | #:abstract 30 | @abstract{ 31 | 32 | This paper presents a Coq library that lifts an 33 | abstract yet precise notion of running-time into the type of a 34 | function. Our library is based on a monad that counts abstract steps. 35 | The monad's computational 36 | content, however, is simply that of the identity monad so programs 37 | written in our monad (that recur on the natural structure of their 38 | arguments) extract into idiomatic OCaml code. 39 | 40 | We evaluated the 41 | expressiveness of the library by proving that red-black tree insertion 42 | and search, merge sort, insertion sort, various Fibonacci number implementations, 43 | iterated list insertion, various BigNum operations, and Okasaki's Braun Tree algorithms all 44 | have their expected running times. 45 | }] 46 | 47 | @section{Introduction} 48 | 49 | For some programs, proving that they have correct input-output 50 | behavior is only part of the story. As @citet[complexity-dos] 51 | observed, incorrect performance characteristics can lead 52 | to security vulnerabilities. Indeed, some programs and algorithms 53 | are valuable precisely because of their performance 54 | characteristics. For example, merge sort is preferable to insertion 55 | sort only because of its improved running time. 56 | Unfortunately, defining functions in Coq or other theorem 57 | proving systems does not provide enough information in the types to 58 | state these intensional properties. 59 | 60 | Our work provides a monad (implemented as a library in Coq) that 61 | enables us to include abstract running times in types. We use this 62 | library to prove that several important algorithms have their expected 63 | running times. 64 | 65 | The monad in our work has similar goals to the one in 66 | @citet[lightweight-semiformal-time-complexity-analysis-for-purely-functional-data-structures]'s, 67 | but with two benefits. 68 | First, it allows programmers 69 | to write idiomatic code without embedding invariants in data types, 70 | so we can reason about a wider variety of programs. Second, and more 71 | significantly, our monad adds no complexity 72 | computations to the extracted OCaml code, so the verification 73 | imposes no run-time overhead. We elaborate these details and differences 74 | throughout the paper and, in particular, in 75 | @secref["sec:related-work"]. 76 | 77 | The rest of the paper is structured as follows. In 78 | @secref["sec:insert"], we give an overview of how the library works 79 | and the style of proofs we support. In @secref["sec:running-time"], we 80 | discuss the cost model our proofs deal with. In 81 | @secref["sec:extract-insert"], we explain the extraction of our 82 | programs to OCaml. In these first three sections, we use a consistent 83 | example that is introduced in @secref["sec:insert"]. Following this 84 | preamble, @secref["sec:monad"] walks through the definition and design 85 | of the monad itself. @Secref["sec:case-study"] describes the results 86 | of our case study, wherein we proved properties of a variety of 87 | different functions. @Secref["sec:prims"] and @secref["sec:other-prims"] 88 | discuss accounting for the running time of various language 89 | primitives. Finally, @secref["sec:related-work"] provides a detailed 90 | account of our relation to similar projects. Our source code and other 91 | supplementary material is available at 92 | @url{https://github.com/rfindler/395-2013}. 93 | 94 | @bold{Extended material:} Compared to the conference proceedings 95 | version of this paper@~cite[coq-library-conference-version], this version contains more elaborate and 96 | detailed figures and proofs throughout, as well as an extended 97 | discussion of language primitive runtimes in @secref["sec:prims"]. 98 | 99 | @include-section["insert.scrbl"] 100 | 101 | @include-section["running-time.scrbl"] 102 | 103 | @include-section["extract-insert.scrbl"] 104 | 105 | @include-section["monad.scrbl"] 106 | 107 | @include-section["case-study.scrbl"] 108 | 109 | @include-section["prims.scrbl"] 110 | 111 | @include-section["other-prims.scrbl"] 112 | 113 | @include-section["related-work.scrbl"] 114 | 115 | @;@section{Conclusion} 116 | 117 | @generate-bibliography[] 118 | 119 | @(include-appendix) 120 | -------------------------------------------------------------------------------- /paper/prims-overview.txt: -------------------------------------------------------------------------------- 1 | Due Diligence for Primitive Operations by function: 2 | 3 | 1. copy2, copy_log_sq, copy_linear, copy_fib_log 4 | - These all alternate performing sub1, div2, sub1, div2 ... in recursive 5 | calls. Plotting and an informal argument suggest that these work out to 6 | amortized constant time for each (div2 (sub1 _)) operation. 7 | 8 | 2. size_linear 9 | - Because of the braun invariant, the additions in this function should be 10 | constant time operations 11 | 12 | 3. fib, drop/take, pad_drop, insert_at, zip_leftn, zip_rightn 13 | - These all decrease their argument linearly by one, always performing 14 | sub1 on the argument results in amortized constant time for each sub1 15 | operation 16 | 17 | 4. clength 18 | - this performs an addition at each iteration which should result in an 19 | amortized constant time operation over all 20 | 21 | 5. mergesortc 22 | - calls pred on the length of the list, but only when the length is 23 | odd so this is a constant time operation 24 | 25 | 6. size_log_sq 26 | - The (+ 1 (* 2 m) zo) term does not take constant time when zo is 1, but 27 | in the worst case that zo is 1 in every recursive call it would contribute 28 | a cost on the order of (log m), because a factor of (log m) is already 29 | accounted for in the time to compute (diff s m) at worst this would change 30 | the constant factor of the runtime, the big_oh calculation should remanin 31 | valid. 32 | 33 | 7. diff 34 | - diff has a complicated recursion pattern. When given an even number it 35 | subtracts 2 then divides by 2. When given an odd number it subtracts 1 and 36 | divides by 2 (both constant time operations in this case). Plots as well 37 | as a similar argument to that for copy_linear suggests that this operation 38 | is also amortized constant time. 39 | 40 | 41 | 42 | TODO: 43 | 44 | 1. Turn due diligence regarding prim ops such as sub1 into an appendix that 45 | discussed why it is ok to not explicitly account for these situations. 46 | 47 | 48 | 49 | 50 | -------------------------------------------------------------------------------- /paper/related-work.scrbl: -------------------------------------------------------------------------------- 1 | #lang scribble/base 2 | @(require "util.rkt" "cite.rkt" scribble/core) 3 | @title[#:tag "sec:related-work"]{Related Work} 4 | 5 | The most closely related work to ours is 6 | @citet[lightweight-semiformal-time-complexity-analysis-for-purely-functional-data-structures], 7 | which presents a monad that carries a notion of abstract time. Unlike 8 | our monad, his does not carry an invariant -- in our terms his 9 | construction does not have the @tt{P} argument. In our opinion, 10 | figuring out the design of monad operations that support the @tt{P} 11 | argument is our primary technical advance. Accordingly, his system 12 | cannot specify the running time of many of the Braun functions, since 13 | the size information is not available without the additional 14 | assumption of Braunness. Of course, one can bake the Braun invariants 15 | into the Braun data-structure itself, which would provide them to his 16 | monad via the function arguments, but this restricts the way the code 17 | is written, leaves residue in the extracted code, and moves the 18 | implementation away from an idiomatic style. Also, his monad leaves 19 | natural numbers in the extracted code; avoiding that is a major goal 20 | of this work. 21 | 22 | While @citet[resource-bound-certification]'s work does not leverage 23 | the full expressiveness of a theorem proving system like Coq's, it 24 | does share a similar resemblance to our approach in that it verifies 25 | the bounded termination of programs but does not infer them. Also 26 | like 27 | @citet[lightweight-semiformal-time-complexity-analysis-for-purely-functional-data-structures]'s 28 | and unlike ours, it does not provide a place to carry an invariant of 29 | the data structures that can be used to establish running times. 30 | 31 | @citet[a-machine-checked-proof-of-the-average-case-complexity-of-quicksort-in-coq] 32 | give a proof of the average case complexity of Quicksort 33 | in Coq. They too use monads, but design a monad that is 34 | specially tailored to counting only comparison operations. 35 | They side-step the extraction problem by abstracting the 36 | implementation over a monad transformer and use one monad 37 | for proving the correct running times and another for 38 | extraction. 39 | 40 | Xi and Pfenning first seriously studied the 41 | idea of using dependent types to describe invariants of 42 | data structures in practical programming 43 | languages@~cite[dependently-typed-datastructures 44 | dependent-types-in-practical-programming-diss 45 | dependent-types-in-practical-programming-popl] 46 | and, indeed, even used Braun trees as 47 | an example in the DML language, which could 48 | automatically prove that, for example, @tt{size_log_sq} is 49 | correct. 50 | 51 | @citet[functors-for-proofs-and-programs] implemented a number of 52 | balanced binary tree implementations in Coq with proofs of 53 | correctness (but not running time), with the goal of high-quality 54 | extraction. They use an ``external'' approach, where the types 55 | do not carry the running time information, whereas we use an ``internal'' approach. We discuss the distinction and our preference in @secref["sec:insert"]. 56 | 57 | @citet[hoare-logic-state-monad]'s Hoare state monad is like our 58 | monad in that it exploits monadic structure to 59 | make proof obligations visible at the right moments. However, 60 | the state used in their monad has computational content and thus 61 | is not erased during extraction. 62 | 63 | @citet[characteristic-formulae-for-mechanized-program-verification] 64 | and @citet[machine-checked-union-find]'s characteristic formula 65 | generator seems to produce Coq code with obligations similar to what 66 | our monad produces, allowing one to reason about running times. 67 | They use a different notion of resources, however, 68 | specifically the number of function entry points visited. 69 | 70 | Others have explored automatic techniques for proving that programs 71 | have particular resource bounds using a variety of 72 | techniques@~cite[speed auto-parallel auto-heap 73 | recursion-in-bounded-space] These approaches are all less expressive 74 | and apply to fewer programs as compared to our approach, but provide 75 | more automation and so are better when they work. 76 | 77 | Similarly, others have explored different approaches for accounting for 78 | various resource bounds and costs, but we do not provide any 79 | contribution in this area. Instead, we take an off-the-shelf cost 80 | semantics (@citet[automatic-complexity-analysis]'s) and use it. We 81 | believe our approach applies to other cost models. 82 | 83 | We have consistently used the word ``monad'' to describe what our 84 | library provides and believe that that is a usefully evocative word to 85 | capture the essence of our library. However, they are not technically 86 | monads for two reasons. First, the monad laws are written using an 87 | equality, but we use an equivalence relation appropriate to our 88 | type. Second, our types have more parameters than the single parameter 89 | used in monads, due to the proof information residing in the types, so 90 | our ``monad'' is actually a generalized form of a monad, a 91 | specialization of @citet[Atkey-generalized-monad]'s or 92 | @citet[ACU-generalized-monad]'s. @citet[hoare-logic-state-monad] and 93 | @citet[dijkstra-monad] follow this same evocative naming convention. 94 | 95 | Our code uses @citet[Program-cite]'s @tt{Program} facility in Coq for 96 | writing dependently-typed programs by separating idiomatic code and 97 | detail-oriented proofs in the program source. Without @tt{Program}, 98 | our programs would have to mix the running time proofs in with the 99 | program, which would greatly obscure the code's connection to the 100 | original algorithm, as one does in 101 | @citet[lightweight-semiformal-time-complexity-analysis-for-purely-functional-data-structures]. 102 | 103 | @citet[machine-checked-union-find]'s work supports imperative code, 104 | whereas we have only experimented with 105 | imperative programs by combining our monad's types with a variation of 106 | the @citet[hoare-logic-state-monad] and @citet[dijkstra-monad] 107 | monads. The types and proofs work out, but are considerably more 108 | complicated, due in part to the complexity of proofs about imperative 109 | programs. We consider it future work to study whether there is a more 110 | elegant approach and develop a detailed case study. 111 | 112 | @; is this related? 113 | @;@citet[correct-by-construction-model-transformations] 114 | 115 | 116 | @(element (style "noindent" '()) '()) 117 | @bold{Acknowledgments.} 118 | Thanks to reviewers of this paper, including previous versions. Thanks to 119 | Neil Toronto for his help with the properties 120 | of integer logarithms (including efficient 121 | implementations of them). 122 | This work grew out of a programming languages seminar at Northwestern; 123 | thanks to 124 | Benjamin English, 125 | Michael Hueschen, 126 | Daniel Lieberman, 127 | Yuchen Liu, 128 | Kevin Schwarz, 129 | Zach Smith, and 130 | Lei Wang 131 | for their feedback on early versions of this work. 132 | 133 | This material is based upon work supported by the National Science Foundation. 134 | 135 | @raw-latex{\newpage} 136 | -------------------------------------------------------------------------------- /paper/util.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/runtime-path 3 | racket/string 4 | racket/match 5 | scribble/base 6 | scribble/core 7 | scribble/manual 8 | "extract.rkt") 9 | (require (for-syntax racket/base)) 10 | 11 | (module+ test 12 | (require rackunit)) 13 | 14 | (define-runtime-path binds.v "binds.v") 15 | (define-runtime-path braun.v "../common/braun.v") 16 | (define-runtime-path insert.rkt "../insert/insert_log_gen.rkt") 17 | (define-runtime-path monad.v "../monad/monad.v") 18 | (define-runtime-path insert_log.v "../insert/insert_log.v") 19 | (define-runtime-path insert_log_gen.v "../insert/insert_log_gen.v") 20 | (define-runtime-path insert_no_gen.v "../insert/insert_nogen.v") 21 | (define-runtime-path sub1_gen.v "../arith/sub1_gen.v") 22 | (define-runtime-path sub1.v "../arith/sub1_gen.v") 23 | (define-runtime-path sub1_linear_loop_gen.v "../arith/sub1_linear_loop_gen.v") 24 | (define-runtime-path fib_iter_loop_gen.v "../fib/fib_iter_loop_gen.v") 25 | (define-runtime-path copy_log_sq_gen.v "../copy/copy_log_sq_gen.v") 26 | (define-runtime-path copy_log_sq.v "../copy/copy_log_sq.v") 27 | (define-runtime-path extract.ml "../extract/extract.ml") 28 | (define-runtime-path size_linear_gen.v "../size/size_linear_gen.v") 29 | (define-runtime-path size_linear.v "../size/size_linear.v") 30 | (define-runtime-path size_log_sq_gen.v "../size/size_log_sq_gen.v") 31 | (define-runtime-path copy_linear_gen.v "../copy/copy_linear_gen.v") 32 | (define-runtime-path diff_gen.v "../size/diff_gen.v") 33 | (define-runtime-path size_linear_bin_gen.v "../size/size_linear_bin_gen.v") 34 | (define-runtime-path size_linear_bin.v "../size/size_linear_bin.v") 35 | 36 | (define-syntax (include-appendix stx) 37 | (syntax-case stx () 38 | [_ (getenv "BUILD-WITH-APPENDIX") #'(include-section "appendix.scrbl")] 39 | [_ #'(void)])) 40 | 41 | 42 | (define (keep-range reg lines) 43 | 44 | (define (drop-up-to reg lines) 45 | (let loop ([lines lines]) 46 | (cond 47 | [(null? lines) lines] 48 | [else 49 | (cond 50 | [(regexp-match reg (car lines)) 51 | lines] 52 | [else (loop (cdr lines))])]))) 53 | 54 | (reverse 55 | (drop-up-to 56 | reg 57 | (reverse (drop-up-to reg lines))))) 58 | 59 | (define (chop-after reg lines) 60 | (cond 61 | [(null? lines) 62 | lines] 63 | [(regexp-match reg (car lines)) 64 | null] 65 | [else 66 | (cons (car lines) (chop-after reg (cdr lines)))])) 67 | 68 | (define (keep-after reg lines) 69 | (cond 70 | [(null? lines) 71 | lines] 72 | [(regexp-match reg (car lines)) 73 | lines] 74 | [else 75 | (keep-after reg (cdr lines))])) 76 | 77 | (module+ test 78 | (check-equal? 79 | (chop-after #rx"bad" 80 | (list "good" "good" "bad" "bad" "bad")) 81 | (list "good" "good"))) 82 | 83 | (provide extract 84 | (all-defined-out)) 85 | 86 | (define (raw-latex . args) 87 | (element (style "relax" '(exact-chars)) 88 | args)) 89 | 90 | (define (snoc l x) 91 | (append l (list x))) 92 | 93 | (define (trim-blank-from-end l) 94 | (match-define (list before ... last (regexp #px"^[:space:]*$" (list _)) ...) l) 95 | (snoc before (string-trim last #:left? #f))) 96 | 97 | (define (inline-code . args) 98 | (compound-paragraph 99 | (style "InlineCode" '()) 100 | (list 101 | (apply 102 | verbatim 103 | (trim-blank-from-end args))))) 104 | 105 | (define extra-tex-code 106 | (bytes-append 107 | #"\\usepackage{pslatex}\n" 108 | #"\\usepackage{inconsolata}\n" 109 | #"\\newenvironment{InlineCode}{\\begin{trivlist}\\item\\footnotesize}{\\end{trivlist}}\n")) 110 | -------------------------------------------------------------------------------- /rbtrees/bst_search_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (Fixpoint 4 | bst_search #:implicit @A{Set} 5 | @A_cmp{A -> A -> Prop} 6 | @A_asym{forall x y, A_cmp x y -> ~ A_cmp y x} 7 | @A_trans{Transitive A A_cmp} 8 | @A_cmp_dec{forall (x y:A), 9 | { A_cmp x y } + { A_cmp y x }} 10 | @A_eq_dec{forall (x y:A), { x = y } + { x <> y }} 11 | @x{A} @ct{CTree A} 12 | #:returns @{bool} 13 | (match (ct) 14 | [(CT_leaf) 15 | => 16 | (<== false)] 17 | [(CT_node l c v r) 18 | => 19 | (match ((A_eq_dec x v)) 20 | [(left _) 21 | => 22 | (<== true)] 23 | [(right _) 24 | => 25 | (match ((A_cmp_dec x v)) 26 | [(left _) 27 | => 28 | (bind ((res (bst_search A_cmp A_asym A_trans A_cmp_dec A_eq_dec x l))) 29 | (<== res))] 30 | [(right _) 31 | => 32 | (bind ((res (bst_search A_cmp A_asym A_trans A_cmp_dec A_eq_dec x r))) 33 | (<== res))])])])) 34 | -------------------------------------------------------------------------------- /rbtrees/match-star.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match) 3 | 4 | (define (do-match* stx) 5 | (match-define `(match* #:else ,else ,pat ...) stx) 6 | (do-match*-inner else pat)) 7 | 8 | (define (ok-pats id pat pats) 9 | (map (ok-pat id pat) pats)) 10 | (define ((ok-pat id pat) this) 11 | (match this 12 | [`[#:ret ,body] this] 13 | [`[{,id0 ,pat0} ,pats ... #:ret ,body] 14 | (if (equal? id id0) 15 | `[,@pats #:ret ,body] 16 | this)])) 17 | 18 | (define (bad-pats id pat pats) 19 | (filter (bad-pat id pat) pats)) 20 | (define ((bad-pat id pat) this) 21 | (match this 22 | [`[#:ret ,body] #t] 23 | [`[{,id0 ,pat0} ,pats ... #:ret ,body] 24 | (if (equal? id id0) #f #t)])) 25 | 26 | (define ID 0) 27 | (define DEFNS (make-hasheq)) 28 | (define MEMO (make-hash)) 29 | (define (do-match*-inner else pats) 30 | (hash-ref! 31 | MEMO pats 32 | (λ () 33 | (match pats 34 | ['() `(<== ,else)] 35 | [(cons `[#:ret ,top-body] pats) 36 | `(<== ,top-body)] 37 | [(cons `[{,id0 ,pat0} ,top-pats ... #:ret ,top-body] pats) 38 | (define new-ok-pats 39 | (cons `[,@top-pats #:ret ,top-body] 40 | (ok-pats id0 pat0 pats))) 41 | (define new-bad-pats 42 | (bad-pats id0 pat0 pats)) 43 | `(match (,id0) 44 | [,pat0 => ,(do-match*-inner else new-ok-pats)] 45 | [_ => ,(do-match*-inner else new-bad-pats)])])))) 46 | 47 | (module+ test 48 | (define t 49 | `(match* #:else (CT_node A tl tc tv tr) 50 | [{tc (BLACK)} {tl (CT_node tll tlc tlv tlr)} {tlc (RED)} 51 | {tll (CT_node tlll tllc tllv tllr)} {tllc (RED)} 52 | #:ret 53 | (CT_node A 54 | (CT_node A tlll BLACK tllv tllr) RED tlv 55 | (CT_node A tlr BLACK tv tr))] 56 | 57 | [{tc (BLACK)} {tl (CT_node tll tlc tlv tlr)} {tlc (RED)} 58 | {tlr (CT_node tlrl tlrc tlrv tlrr)} {tlrc (RED)} 59 | #:ret 60 | (CT_node A (CT_node A tll BLACK tlv tlrl) RED tlrv 61 | (CT_node A tlrr BLACK tv tr))] 62 | 63 | [{tc (BLACK)} {tr (CT_node trl trc trv trr)} {trc (RED)} 64 | {trl (CT_node trll trlc trlv trlr)} {trlc (RED)} 65 | #:ret 66 | (CT_node A (CT_node A tl BLACK tv trll) RED trlv 67 | (CT_node A trlr BLACK trv trr))] 68 | 69 | [{tc (BLACK)} {tr (CT_node trl trc trv trr)} {trc (RED)} 70 | {trr (CT_node trrl trrc trrv trrr)} {trrc (RED)} 71 | #:ret 72 | (CT_node A (CT_node A tl BLACK tv trl) RED trv 73 | (CT_node A trrl BLACK trrv trrr))])) 74 | (require racket/pretty) 75 | (pretty-print (do-match* t)) 76 | (pretty-print DEFNS)) 77 | -------------------------------------------------------------------------------- /rbtrees/rbt_blacken_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide rbt_blacken) 3 | 4 | (Fixpoint 5 | rbt_blacken 6 | @A{Set} @ct{CTree A} 7 | #:returns @{CTree A} 8 | (match (ct) 9 | [(CT_leaf) 10 | => 11 | (<== ct)] 12 | [(CT_node l c v r) 13 | => 14 | (<== (CT_node A l BLACK v r))])) 15 | -------------------------------------------------------------------------------- /rbtrees/rbt_insert_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "rbt_insert_inner_gen.rkt" "rbt_blacken_gen.rkt") 3 | 4 | (Fixpoint 5 | rbt_insert 6 | @A{Set} 7 | @A_cmp{A -> A -> Prop} 8 | @A_refl{forall x, A_cmp x x} 9 | @A_asym{forall x y, A_cmp x y -> ~ A_cmp y x} 10 | @A_trans{Transitive A A_cmp} 11 | @A_cmp_dec{forall (x y:A), 12 | { A_cmp x y } + { A_cmp y x }} 13 | @A_eq_dec{forall (x y:A), { x = y } + { x <> y }} 14 | @ct{CTree A} @x{A} 15 | #:returns @{CTree A} 16 | (bind 17 | ((ctp (rbt_insert_inner A A_cmp A_refl A_asym A_trans A_cmp_dec A_eq_dec ct x))) 18 | (bind 19 | ((res (rbt_blacken A ctp))) 20 | (<== res)))) 21 | -------------------------------------------------------------------------------- /rbtrees/rbt_insert_inner_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide rbt_insert_inner) 3 | (require "rbt_balance_gen.rkt") 4 | 5 | (Fixpoint 6 | rbt_insert_inner 7 | @A{Set} 8 | @A_cmp{A -> A -> Prop} 9 | @A_refl{forall x, A_cmp x x} 10 | @A_asym{forall x y, A_cmp x y -> ~ A_cmp y x} 11 | @A_trans{Transitive A A_cmp} 12 | @A_cmp_dec{forall (x y:A), 13 | { A_cmp x y } + { A_cmp y x }} 14 | @A_eq_dec{forall (x y:A), { x = y } + { x <> y }} 15 | @ct{CTree A} @x{A} 16 | #:returns @{CTree A} 17 | (match (ct) 18 | [(CT_leaf) 19 | => 20 | (<== (CT_node A ct RED x ct))] 21 | [(CT_node l c v r) 22 | => 23 | (match ((A_eq_dec x v)) 24 | [(left _) 25 | => 26 | (<== ct)] 27 | [(right _) 28 | => 29 | (match ((A_cmp_dec x v)) 30 | [(left _) 31 | => 32 | (bind 33 | ((lp (rbt_insert_inner A A_cmp A_refl A_asym A_trans A_cmp_dec A_eq_dec l x))) 34 | (bind 35 | ((res (rbt_balance A lp c v r))) 36 | (<== res)))] 37 | [(right _) 38 | => 39 | (bind 40 | ((rp (rbt_insert_inner A A_cmp A_refl A_asym A_trans A_cmp_dec A_eq_dec r x))) 41 | (bind 42 | ((res (rbt_balance A l c v rp))) 43 | (<== res)))])])])) 44 | -------------------------------------------------------------------------------- /rbtrees/rbt_search.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.common.util Braun.common.le_util Braun.common.same_structure. 2 | Require Import Braun.common.log Braun.common.big_oh Braun.common.pow. 3 | Require Import Braun.monad.monad. 4 | Require Import Program. 5 | Require Import Omega. 6 | Require Import Max. 7 | Require Import Div2. 8 | Require Import Relations_1. 9 | Require Import Braun.rbtrees.rbtree. 10 | 11 | Definition bst_search_time (n:nat) := 12 | 19 * n + 3. 13 | 14 | Definition bst_search_result (A:Set) 15 | (A_cmp:A -> A -> Prop) 16 | (A_asym:forall x y, A_cmp x y -> ~ A_cmp y x) 17 | (A_trans:Transitive A A_cmp) 18 | (A_cmp_dec: 19 | forall (x y:A), 20 | { A_cmp x y } + { A_cmp y x }) 21 | (A_eq_dec: 22 | forall (x y:A), 23 | { x = y } + { x <> y }) 24 | (x:A) (ct:CTree A) (res:bool) (c:nat) := 25 | forall (min_a max_a:A) 26 | (MIN:A_cmp min_a x) 27 | (MAX:A_cmp x max_a) 28 | (BST:IsBST A_cmp ct min_a max_a), 29 | (res = true -> IsMember x ct) /\ 30 | (res = false -> ~ IsMember x ct) /\ 31 | 1 <= c <= bst_search_time (height ct). 32 | 33 | Load "bst_search_gen.v". 34 | 35 | Next Obligation. 36 | Proof. 37 | unfold bst_search_result, bst_search_time. 38 | intros min_a max_a CMPax CMPxa BST. 39 | split. 40 | intros EQ. inversion EQ. 41 | simpl. 42 | split; try omega. 43 | intros _ IM. 44 | inversion IM. 45 | Qed. 46 | 47 | Next Obligation. 48 | Proof. 49 | unfold bst_search_result, bst_search_time. 50 | intros min_a max_a CMPax CMPxa BST. 51 | split. 52 | intros _. eauto. 53 | split. 54 | intros EQ. congruence. 55 | simpl (height (CT_node A l c v r)). 56 | rewrite mult_succ_r. 57 | omega. 58 | Qed. 59 | 60 | Obligation Tactic := idtac. 61 | Next Obligation. 62 | Proof. 63 | unfold bst_search_result, bst_search_time. 64 | intros A A_cmp A_asym A_trans A_cmp_dec A_eq_dec x ct. 65 | intros l c v r EQ. subst ct. 66 | intros NEQ _ CMPxv _. 67 | intros res. 68 | intros _. 69 | intros xm EQ. simpl in EQ. subst xm. 70 | intros an REC. 71 | intros min_a max_a CMPax CMPxa BST. 72 | edestruct REC as [IMt [IMf AN]]. 73 | apply CMPax. 74 | apply CMPxv. 75 | inversion BST. subst. auto. 76 | clear REC. 77 | 78 | split. 79 | intros EQ. apply IMt in EQ. eauto. 80 | split. 81 | intros EQ. apply IMf in EQ. 82 | intros IM. inversion IM; subst; auto. 83 | rename H0 into IMr. 84 | inversion BST. 85 | subst. 86 | rename H3 into BSTl. 87 | rename H6 into CMPav. 88 | rename H7 into CMPva. 89 | rename H8 into BSTr. 90 | 91 | edestruct IsMember_impl_bounds. 92 | apply A_trans. 93 | apply BSTr. 94 | apply IMr. 95 | rename H into CMPvx. 96 | clear H0. 97 | eapply A_asym. 98 | apply CMPvx. 99 | auto. 100 | 101 | simpl (height (CT_node A l c v r)). 102 | remember (height l) as L. 103 | remember (height r) as R. 104 | clear HeqR HeqL IMf IMt CMPxv NEQ BST r v c l CMPxa CMPax max_a min_a x A_eq_dec 105 | A_cmp_dec A_trans A_asym A_cmp A res. 106 | rewrite mult_succ_r. 107 | rewrite <- plus_assoc. 108 | replace (19 + 3) with 22; try omega. 109 | apply max_case_strong. 110 | intros LE. clear LE R. omega. 111 | intros LE. omega. 112 | Qed. 113 | Obligation Tactic := program_simpl. 114 | 115 | Obligation Tactic := idtac. 116 | Next Obligation. 117 | Proof. 118 | unfold bst_search_result, bst_search_time. 119 | intros A A_cmp A_asym A_trans A_cmp_dec A_eq_dec x ct. 120 | intros l c v r EQ. subst ct. 121 | intros NEQ _ CMPvx _. 122 | intros res. 123 | intros _. 124 | intros xm EQ. simpl in EQ. subst xm. 125 | intros an REC. 126 | intros min_a max_a CMPax CMPxa BST. 127 | edestruct REC as [IMt [IMf AN]]. 128 | apply CMPvx. 129 | apply CMPxa. 130 | inversion BST. subst. auto. 131 | clear REC. 132 | split. 133 | intros EQ. apply IMt in EQ. eauto. 134 | split. 135 | intros EQ. apply IMf in EQ. 136 | intros IM. inversion IM; subst; auto. 137 | rename H0 into IMl. 138 | inversion BST. 139 | subst. 140 | rename H3 into BSTl. 141 | rename H6 into CMPav. 142 | rename H7 into CMPva. 143 | rename H8 into BSTr. 144 | 145 | edestruct IsMember_impl_bounds. 146 | apply A_trans. 147 | apply BSTl. 148 | apply IMl. 149 | clear H. 150 | rename H0 into CMPxv. 151 | eapply A_asym. 152 | apply CMPvx. 153 | auto. 154 | 155 | simpl (height (CT_node A l c v r)). 156 | remember (height l) as L. 157 | remember (height r) as R. 158 | clear HeqR HeqL IMf IMt CMPvx NEQ BST r v c l CMPxa CMPax max_a min_a x A_eq_dec 159 | A_cmp_dec A_trans A_asym A_cmp A res. 160 | apply max_case_strong. 161 | intros LE. omega. 162 | intros LE. clear LE L. omega. 163 | Qed. 164 | Obligation Tactic := program_simpl. 165 | 166 | Corollary rbbst_search_time_bound_black_height: 167 | forall A (ct:CTree A) n, 168 | IsRB ct n -> 169 | bst_search_time (height ct) <= 38 * n + 22. 170 | Proof. 171 | intros A ct n IR. 172 | unfold bst_search_time. 173 | apply IsRB_impl_height_no_color in IR. 174 | omega. 175 | Qed. 176 | 177 | Corollary bst_search_time_theta: 178 | big_theta bst_search_time (fun n => n). 179 | Proof. 180 | unfold bst_search_time. 181 | apply big_theta_mult_plus. 182 | Qed. 183 | -------------------------------------------------------------------------------- /rkt/README.txt: -------------------------------------------------------------------------------- 1 | To make the coq-to-coq fit into the Makefile and get it to generate 2 | the right += expressions requires a few steps. 3 | 4 | Create a racket file that contains an implementation of the function 5 | in the monad, either using the parenthesized notation, like 6 | rkt/diff.rkt, or the coq reader (which has less support), like 7 | rkt/insert.rkt. 8 | 9 | This is a standalone program that will run (even if the function 10 | doesn't typecheck) and can be used to compute the running time as well 11 | as the results. Eg: 12 | 13 | Welcome to Racket v6.1.1.8. 14 | > (require "diff.rkt" tmonad) 15 | > (diff (bt_node 1 bt_mt bt_mt) 1) 16 | 0 17 | 15 18 | 19 | The first result is the result of the function and the second result 20 | is the number of abstract steps. This can be useful to experiment with 21 | the running time as a function of the input size when you're not sure 22 | what the precise running time is. 23 | 24 | The tmonad language also generates a main module which, when run, 25 | prints out the coq code for the function with the right += expressions 26 | inserted. Eg: 27 | 28 | % racket diff.rkt 29 | (* this file was generated automatically from diff.rkt *) 30 | Program Fixpoint diff {A:Set} (b:@bin_tree A) (m:nat) {measure m} 31 | : {! res !:! nat !! 32 | diff_result A b m res c !} := 33 | match b, m with 34 | | bt_mt, _ => 35 | += 4; 36 | <== 0 37 | | bt_node x _ _, 0 => 38 | += 4; 39 | <== 1 40 | | bt_node x s t, S m' => 41 | if (even_odd_dec m) 42 | then (o <- diff t (div2 (m' - 1)); 43 | += 13; 44 | <== o) 45 | else (o <- diff s (div2 m'); 46 | += 11; 47 | <== o) 48 | end. 49 | 50 | This generated code has the free variable "diff_result" in but 51 | otherwise it has the same things as in the Racket version (the 52 | tmonad language includes things like even_odd_dec and div2 and 53 | other things of that ilk to run the programs in Racket, but they just 54 | turn into Coq identifiers in the generated code output). 55 | 56 | To use it in coq, add the "racket diff.rkt" command-line to the 57 | Makefile: 58 | 59 | size/diff_gen.v: rkt/diff.rkt $(GEN_DEPS) 60 | racket rkt/diff.rkt > size/diff_gen.v 61 | 62 | using GEN_DEPS as a dependency as well as the racket input file. 63 | 64 | Also, add a dependency to the tmonad-gen line in the Makefile, in this 65 | case, since the results are then put into size/diff_gen.v, add 66 | size/diff_gen.v to the tmonad-gen dependency list. 67 | 68 | Then, in the Coq file where you will use this function, 69 | size/size_log_sq.v in this case, add: 70 | 71 | Load "diff_gen.v" 72 | 73 | but be sure that you've defined diff_result first. 74 | 75 | Once that is all set up the coq-side automatic makefile generation 76 | should work, picking up the dependency on the "Load"ed file. 77 | -------------------------------------------------------------------------------- /rkt/braun.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (provide (all-defined-out)) 3 | 4 | ;; a braun tree is either #f or (node any braun-tree bran-tree nat) 5 | (struct node (v l r s) #:transparent) 6 | 7 | (define (size n) 8 | (cond 9 | [(node? n) (node-s n)] 10 | [else 0])) 11 | 12 | (define (mknode l r #:val [v #f]) 13 | (unless (<= (size r) (size l) (+ (size r) 1)) 14 | (error 'mknode "invariant check failed:\n (size l) = ~s l = ~s\n (size r) = ~s r = ~s" 15 | (size l) l 16 | (size r) r)) 17 | (node v l r (+ (size l) (size r) 1))) 18 | 19 | 20 | ;; no tests 21 | (module test racket/base) -------------------------------------------------------------------------------- /rkt/copy_linear_sub1.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "../arith/sub1_gen.rkt") 3 | (provide copy_linear_sub1) 4 | (Fixpoint 5 | copy_linear_sub1 @n{nat} 6 | #:measure n 7 | #:returns @{nat} 8 | (match (n) 9 | [0 => (<== 0)] 10 | [(S _) 11 | => 12 | (bind ((l (copy_linear_sub1 (div2 n)))) 13 | (bind ((nn (sub1 n))) 14 | (bind ((r (copy_linear_sub1 (div2 nn)))) 15 | (<== 0))))])) 16 | -------------------------------------------------------------------------------- /rkt/diff-sub-div-plot.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "../arith/sub1_gen.rkt") 3 | (require plot) 4 | (provide diff-sub/div-plot) 5 | 6 | (define (div2 n) (quotient n 2)) 7 | 8 | (define (diff-sub/div-loop n) 9 | (define count 0) 10 | (define (inc) (set! count (add1 count))) 11 | (define (diff-sub/div-loop/a n acc) 12 | (inc) 13 | (cond 14 | [(zero? n) (+ acc 1)] 15 | [(even? n) 16 | (define-values (a1 t1) (sub1 n)) 17 | (define-values (a2 t2) (sub1 a1)) 18 | (diff-sub/div-loop/a (div2 a2) (+ acc t1 t2 1))] 19 | [(odd? n) 20 | (define-values (a1 t1) (sub1 n)) 21 | (diff-sub/div-loop/a (div2 a1) (+ acc t1 1))])) 22 | (values (diff-sub/div-loop/a n 0) count)) 23 | 24 | (define diff-sub/div-plot 25 | (plot-pict 26 | #:width 250 27 | #:height 250 28 | #:x-label "Argument to diff" 29 | #:y-label "Average Number of Abstract Steps" 30 | (points 31 | (for/list ([i (in-range 1024)]) 32 | (define-values (time len) (diff-sub/div-loop i)) 33 | (vector i (/ time len)))))) 34 | 35 | (define (make-bad n) 36 | (cond 37 | [(zero? n) 2] 38 | [else 39 | (+ (* 4 (make-bad (sub1 n))) 2)])) 40 | 41 | (define (t n) 42 | (define-values (time len) (diff-sub/div-loop (make-bad n))) 43 | (/ time len)) 44 | 45 | (define (make-bad2 n) 46 | (cond 47 | [(zero? n) 2] 48 | [else 49 | (* 2 (+ (make-bad2 (- n 1)) 1))])) 50 | 51 | 52 | 53 | (define (t2 n) 54 | (define-values (time len) (diff-sub/div-loop (make-bad2 n))) 55 | (/ time len)) 56 | -------------------------------------------------------------------------------- /rkt/diff_sub1.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide diff_sub1) 3 | (require "../arith/sub1_gen.rkt") 4 | 5 | (Fixpoint 6 | diff_sub1 @n{nat} @m{nat} 7 | #:measure m 8 | #:returns @{nat} 9 | (match (n m) 10 | [0 _ => (<== 0)] 11 | [(S _) 0 => (<== 1)] 12 | [(S _) (S _) 13 | => 14 | (if (even_odd_dec m) 15 | (bind ([mm (sub1 m)]) 16 | (bind ([mmm (sub1 mm)]) 17 | (bind ((o (diff_sub1 (div2 n) (div2 mmm)))) 18 | (<== o)))) 19 | (bind ([mm (sub1 m)]) 20 | (bind ((o (diff_sub1 (div2 (- n 1)) (div2 mm)))) 21 | (<== o))))])) 22 | -------------------------------------------------------------------------------- /rkt/fib-facts.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | 3 | (require plot 4 | "log.rkt" 5 | math/base 6 | racket/trace) 7 | 8 | (define (fib n) 9 | (cond 10 | [(= n 0) 0] 11 | [(= n 1) 1] 12 | [else (+ (fib (- n 1)) 13 | (fib (- n 2)))])) 14 | 15 | #| 16 | Program Fixpoint rt_copy_fib (n : nat) {measure n}: nat := 17 | match n with 18 | | 0 => 1 19 | | (S n') => if (even_odd_dec n) 20 | then (S ((rt_copy_fib (div2 n)) + (rt_copy_fib (div2 n')))) 21 | else (S (rt_copy_fib (div2 n))) 22 | end. 23 | |# 24 | 25 | (define (rtcf n) 26 | (cond 27 | [(= n 0) 3] 28 | [(even? n) (+ 19 (rtcf (div2 n)) (rtcf (div2 (sub1 n))))] 29 | [else (+ 13 (rtcf (div2 n)))])) 30 | 31 | #| 32 | P2MO (2^n - 1) = 1 + P2MO (2^(n-1) - 1) 33 | (fl_log) 34 | |# 35 | 36 | (define (p2sub1 n) 37 | (cond 38 | [(zero? n) 1] 39 | [else (+ 1 (p2sub1 (div2 n)))])) 40 | 41 | #| 42 | P2 2^n = 1 + P2 2^(n-1) + P2MO (2^(n-1) - 1) 43 | |# 44 | 45 | (define (p2 n) 46 | (cond 47 | [(zero? n) 0] 48 | [else (+ 1 (p2 (div2 n)) (p2sub1 (div2 (sub1 n))))])) 49 | 50 | (define pows (list 8 16 32 64 128 256 512)) 51 | (define maxes (list 12 26 52 106 212 426)) 52 | 53 | ;; maxes (between powers of 2) are at the 54 | ;; generalized Jacobsthal numbers: 55 | ;; 5*2^n/3 + (-1)^n/3 - 1 56 | ;; http://oeis.org/A084170 57 | (define (gj n) 58 | (+ (* (/ 5 3) (expt 2 n)) 59 | (/ (expt (- 1) n) 3) 60 | (- 1))) 61 | 62 | ;; recursive spec for the gjn's 63 | ;; a(n)=a(n-1)+2*a(n-2)+2, a(0)=1, a(1)=2. 64 | (define (gj2 n) 65 | (cond 66 | [(= n 0) 1] 67 | [(= n 1) 2] 68 | [else (+ (gj2 (- n 1)) 69 | (* 2 (gj2 (- n 2))) 70 | 2)])) 71 | 72 | (define gjs (for/list ([n (in-range 10)]) (gj n))) 73 | (define (is-gj? n) (member n gjs)) 74 | 75 | (define (f n) 76 | (cond 77 | [(= n 0) 3] 78 | [(= n 1) 16] 79 | [else (+ 19 80 | (f (div2 n)) 81 | (g (div2 n)))])) 82 | 83 | (define (g n) 84 | (cond 85 | [(= n 0) 3] 86 | [(= n 1) 16] 87 | [else (+ 13 (f (div2 n)))])) 88 | 89 | (define (f2 n) 90 | (cond 91 | [(= n 0) 3] 92 | [(= n 1) 16] 93 | [else (+ 32 94 | (f2 (div2 n)) 95 | (f2 (div2 (div2 n))))])) 96 | 97 | (define (p n) 98 | (cond 99 | [(= n 0) 0] 100 | [(= n 1) 1] 101 | [else (+ 1 102 | (p (div2 n)) 103 | (p (div2 (div2 n))))])) 104 | 105 | #| 106 | Program Fixpoint pow2 (n : nat) {measure n} : nat := 107 | match n with 108 | | 0 => 0 109 | | 1 => 1 110 | | (S n) => 2 * pow2 n 111 | end. 112 | |# 113 | 114 | (define (pow2 n) 115 | (match n 116 | [0 0] 117 | [1 1] 118 | [_ (* 2 (pow2 (sub1 n)))])) 119 | 120 | #| 121 | 122 | even n -> rtcf n <= f n 123 | odd n -> rtcf n <= g n 124 | 125 | |# 126 | 127 | (define (make-plot upper-bound) 128 | (plot 129 | #:x-label "n" 130 | (list 131 | (lines 132 | #:color 'black 133 | (for/list ([n (in-range upper-bound)]) 134 | (vector n (rtcf n)))) 135 | (lines 136 | #:color 'blue 137 | (for/list ([n (in-range upper-bound)]) 138 | (vector n (p2sub1 n)))) 139 | (lines 140 | #:color 'green 141 | (for/list ([n (in-range upper-bound)]) 142 | (vector n (p n)))) 143 | (lines 144 | #:color 'red 145 | (for/list ([n (in-range upper-bound)]) 146 | (vector n (f n)))) 147 | (lines 148 | #:color 'orange 149 | (for/list ([n (in-range upper-bound)]) 150 | (vector n (g n)))) 151 | (lines 152 | #:color 'purple 153 | (for/list ([n (in-range upper-bound)]) 154 | (vector n (* 72 (fib (cl_log n)))))) 155 | (lines 156 | #:color 'purple 157 | (for/list ([n (in-range upper-bound)]) 158 | (vector n (* 3.5 (fib (cl_log n)))))) 159 | (points 160 | #:color 'blue 161 | (for/list ([n (in-range upper-bound)] 162 | #:when (power-of-two? n)) 163 | (vector (sub1 n) (rtcf (sub1 n))))) 164 | (points 165 | #:color 'green 166 | (for/list ([n (in-range upper-bound)] 167 | #:when (power-of-two? n)) 168 | (vector n (rtcf n)))) 169 | (points 170 | #:color 'red 171 | (for/list ([n (in-range upper-bound)] 172 | #:when (is-gj? n)) 173 | (vector n (rtcf n))))))) 174 | 175 | (define (make-plot2 upper-bound) 176 | (plot 177 | #:x-label "n" 178 | (list 179 | (lines 180 | #:color 'green 181 | (for/list ([n (in-range upper-bound)]) 182 | (vector n (p n)))) 183 | (lines 184 | #:color 'purple 185 | (for/list ([n (in-range upper-bound)]) 186 | (vector n (fib (cl_log n))))) 187 | (lines 188 | #:color 'red 189 | (for/list ([n (in-range upper-bound)]) 190 | (vector n (* 4 (fib (cl_log n))))))))) 191 | 192 | #; 193 | (trace rtcf 194 | p2sub1 195 | p2) -------------------------------------------------------------------------------- /rkt/fib-rt.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../fib/fib_iter_gen.rkt" 3 | plot) 4 | 5 | (printf "fib_iter appears to be worse than n * (log(n))^2\n") 6 | (plot 7 | (list 8 | (lines 9 | #:color "red" 10 | (for/list ([i (in-range 200)]) 11 | (define-values (ans time) (fib_iter i)) 12 | (vector i time))) 13 | (lines 14 | #:color "blue" 15 | (for/list ([i (in-range 1 200)]) 16 | (vector i (* i (expt (log i) 2))))))) 17 | -------------------------------------------------------------------------------- /rkt/log.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (provide (all-defined-out)) 3 | 4 | (define (div2 n) (quotient n 2)) 5 | 6 | (define (fl_log-slow n) 7 | (cond 8 | [(zero? n) 0] 9 | [else (+ (fl_log (div2 (- n 1))) 1)])) 10 | 11 | (define (cl_log-slow n) 12 | (cond 13 | [(zero? n) 0] 14 | [else (+ (cl_log (div2 n)) 1)])) 15 | 16 | ;; faster versions 17 | (define (cl_log n) (integer-length n)) 18 | (define (fl_log n) (sub1 (integer-length (add1 n)))) 19 | 20 | 21 | (module+ test 22 | (printf "testing fl_log and cl_log\n") 23 | (unless (equal? (map fl_log '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) 24 | (map values '(0 1 1 2 2 2 2 3 3 3 3 3 3 3 3 4))) 25 | (error 'fl_log "wrong")) 26 | 27 | (unless (equal? (map cl_log '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)) 28 | (map values '(0 1 2 2 3 3 3 3 4 4 4 4 4 4 4 4))) 29 | (error 'cl_log "wrong")) 30 | 31 | (printf "testing against fl_log-slow and cl_log-slow\n") 32 | (for ([i (in-range 2048)]) 33 | (unless (= (fl_log-slow i) (fl_log i)) 34 | (error 'fl_log "slow doesn't match for ~a")) 35 | (unless (= (cl_log-slow i) (cl_log i)) 36 | (error 'cl_log "slow doesn't match for ~a")))) 37 | -------------------------------------------------------------------------------- /rkt/make-array-test.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "../make_array/make_array_nlogn1_gen.rkt" 3 | "../make_array/make_array_nlogn2_gen.rkt" 4 | "../make_array/make_array_linear_gen.rkt") 5 | 6 | (define (check-against-naive make-array) 7 | (printf "testing ~a against make_array_naive\n" (object-name make-array)) 8 | (for ([i (in-range 1000)]) 9 | (define l (build-list i values)) 10 | (define-values (t1 time1) (make_array_naive l)) 11 | (define-values (t2 time2) (make-array l)) 12 | (unless (equal? t1 t2) 13 | (error 'make-array-test.rkt 14 | "make_array_naive and ~s trees don't match at size ~a:\n ~s\n ~s" 15 | (object-name make-array) 16 | i 17 | t1 18 | t2)))) 19 | 20 | (check-against-naive make_array_td) 21 | (check-against-naive make_array_linear) 22 | 23 | (require racket/contract) 24 | (define/contract (fbt_rs_3 k len) 25 | (-> (and/c natural-number/c 26 | (>=/c 1)) 27 | natural-number/c 28 | natural-number/c) 29 | (cond 30 | [(zero? len) 1] 31 | [else (+ k (fbt_rs_3 (* 2 k) (n- len k)))])) 32 | 33 | (define (n- a b) (max 0 (- a b))) 34 | 35 | (printf "testing (fbt_rs_3 k n) <= (+ (* 2 n) k)\n") 36 | (for ([n (in-range 1000)]) 37 | (for ([k (in-range 1 1000)]) 38 | (define ans (fbt_rs_3 k n)) 39 | (define bound (+ (* 2 n) k)) 40 | (unless (<= ans bound) 41 | (eprintf "no! n=~a k=~a; ~s vs ~s\n" 42 | n 43 | ans bound)))) 44 | -------------------------------------------------------------------------------- /rkt/make-array.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "braun.rkt" "log.rkt") 3 | 4 | (module+ slideshow (require slideshow plot "pict.rkt")) 5 | 6 | (define (insert x bt) 7 | (match bt 8 | [#f (mknode #:val x #f #f)] 9 | [(node y s t _) (mknode #:val x (insert y t) s)])) 10 | 11 | (define (naive-make-array xs) 12 | (cond 13 | [(null? xs) #f] 14 | [else 15 | (insert (car xs) (naive-make-array (cdr xs)))])) 16 | 17 | (define (index bt i) 18 | (match bt 19 | [(node x s t _) 20 | (cond 21 | [(zero? i) x] 22 | [(odd? i) (index s (/ (- i 1) 2))] 23 | [(even? i) (index t (/ (- i 2) 2))])])) 24 | 25 | (module+ test 26 | (printf "testing naive-make-array+index\n") 27 | (for ([size (in-range 1000)]) 28 | (define bt (naive-make-array (build-list size values))) 29 | (for ([i (in-range size)]) 30 | (define i2 (index bt i)) 31 | (unless (= i i2) 32 | (error 'naive-make-array+index "bt size ~a index ~a, got ~a" 33 | size 34 | i 35 | i2))))) 36 | 37 | (define (keep-evens l) 38 | (match l 39 | ['() '()] 40 | [(cons x xs) 41 | (match xs 42 | ['() (cons x '())] 43 | [(cons y ys) (cons x (keep-evens ys))])])) 44 | 45 | (define (keep-odds l) 46 | (match l 47 | ['() '()] 48 | [(cons x xs) 49 | (keep-evens xs)])) 50 | 51 | (define (make-array-even-odd-property x ls) 52 | (define s1 (naive-make-array (keep-evens ls))) 53 | (define t1 (naive-make-array (keep-odds ls))) 54 | (match (naive-make-array (cons x ls)) 55 | [(node x s2 t2 _) 56 | (and (equal? s1 s2) 57 | (equal? t1 t2))] 58 | [else #f])) 59 | 60 | (module+ test 61 | (printf "testing make-array-even-odd-property\n") 62 | (for ([x (in-range 512)]) 63 | (unless (make-array-even-odd-property 0 (build-list x add1)) 64 | (error 'make-array-even-odd-property "failed for size ~a" x)))) 65 | 66 | 67 | (module+ slideshow 68 | (slide 69 | (apply 70 | para 71 | #:width 800 72 | (for/list ([i (in-range 32)]) 73 | (tree->pict (naive-make-array (build-list i values)) 74 | #f))))) 75 | 76 | (define (unravel+time l) 77 | (cond 78 | [(null? l) (values '() '() 0)] 79 | [else 80 | (define-values (odds evens time) (unravel+time (cdr l))) 81 | (values (cons (car l) evens) odds (+ time 1))])) 82 | 83 | (define (td-make-array+time l) 84 | (cond 85 | [(null? l) (values #f 0)] 86 | [else 87 | (define-values (odds evens time1) (unravel+time (cdr l))) 88 | (define-values (left time2) (td-make-array+time odds)) 89 | (define-values (right time3) (td-make-array+time evens)) 90 | (values (mknode #:val (car l) left right) 91 | (+ time1 time2 time3 1))])) 92 | 93 | (define (td-make-array l) 94 | (define-values (bt time) (td-make-array+time l)) 95 | bt) 96 | 97 | (module+ test 98 | (printf "testing td-make-array against naive-make-array\n") 99 | (let () 100 | (define l '()) 101 | (for ([i (in-range 1024)]) 102 | (unless (equal? (td-make-array l) 103 | (naive-make-array l)) 104 | (error 'td-make-array "disagrees with naive-make-array for ~s" l)) 105 | (set! l (cons i l))))) 106 | 107 | (define (td-make-array-time l) 108 | (define-values (bt time) (td-make-array+time l)) 109 | time) 110 | 111 | (define (td-make-array-time2 len) 112 | (cond 113 | [(zero? len) 0] 114 | [else 115 | (+ (td-make-array-time2 (div2 len)) 116 | (td-make-array-time2 (div2 (- len 1))) 117 | len)])) 118 | 119 | (module+ test 120 | (printf "testing td-make-array's time\n") 121 | (let () 122 | (define l '()) 123 | (for ([i (in-range 1024)]) 124 | (define real-time (td-make-array-time l)) 125 | (define hoped-for-time (td-make-array-time2 i)) 126 | (unless (equal? real-time hoped-for-time) 127 | (error 'td-make-array-time 128 | "disagrees with naive-make-array for ~s: real ~s hoped-for ~s" 129 | i 130 | real-time 131 | hoped-for-time)) 132 | (set! l (cons i l))))) 133 | 134 | (module+ slideshow 135 | (require (only-in math fllog2)) 136 | (define (plot-td-make-array-time upper-bound) 137 | (plot-pict 138 | #:x-label "n" 139 | #:y-label "make_array_time(n) & n*cl_log(n)" 140 | (list 141 | (lines 142 | (for/list ([n (in-range upper-bound)]) 143 | (vector n (td-make-array-time2 n)))) 144 | (lines 145 | #:color "red" 146 | (for/list ([n (in-range upper-bound)]) 147 | (vector n (* n (cl_log n)))))))) 148 | 149 | (slide 150 | (scale-to-fit 151 | (hc-append 40 152 | (plot-td-make-array-time (expt 2 11)) 153 | (plot-td-make-array-time 10)) 154 | client-w client-h))) 155 | -------------------------------------------------------------------------------- /rkt/mergesort-strange-fact.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require "log.rkt") 3 | 4 | (define (strange-fact? n) 5 | (<= (+ (* (div2 (+ n 4)) (fl_log (+ n 5))) (fl_log (+ n 5))) 6 | (+ (* (div2 (+ n 4)) (fl_log (+ n 3))) n 5))) 7 | 8 | (module+ main 9 | (let/ec k 10 | (for ([x (in-naturals)]) 11 | (unless (strange-fact? x) 12 | (eprintf "failed at ~a\n" x) 13 | (k (void))) 14 | (when (zero? (modulo x 10000000)) 15 | (printf "holds up to ~a\n" x))))) 16 | -------------------------------------------------------------------------------- /rkt/pict.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require pict "braun.rkt") 3 | 4 | (provide (all-defined-out)) 5 | 6 | (define (tree->pict t path) 7 | (match t 8 | [#f (define b (blank)) 9 | (refocus (cc-superimpose b (filled-ellipse 5 5)) 10 | b)] 11 | [(node val l r _) 12 | (define which-way (and (pair? path) (car path))) 13 | (define lp (tree->pict l (and (equal? which-way 'l) (cdr path)))) 14 | (define rp (tree->pict r (and (equal? which-way 'r) (cdr path)))) 15 | (define main (vc-append (if val 16 | (colorize (inset (text (format "~s" val)) 0 -4 0 4) "DarkGreen") 17 | (blank 0 10)) 18 | (ht-append 10 lp rp))) 19 | (define left-arrow (launder 20 | (pin-line 21 | (ghost main) 22 | main ct-find 23 | lp ct-find))) 24 | (define right-arrow (launder 25 | (pin-line 26 | (ghost main) 27 | main ct-find 28 | rp ct-find))) 29 | (ct-superimpose (linewidth 2 30 | (if (equal? which-way 'l) 31 | (colorize left-arrow "red") 32 | (colorize left-arrow (if val "gray" "black")))) 33 | (linewidth 2 34 | (if (equal? which-way 'r) 35 | (colorize right-arrow "red") 36 | (colorize right-arrow (if val "gray" "black")))) 37 | main)])) 38 | 39 | ;; no tests 40 | (module test racket/base) -------------------------------------------------------------------------------- /rkt/size-scratch.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/overly-specific 2 | (require "braun.rkt" "log.rkt" 3 | (prefix-in fp: 4 | (combine-in 5 | "../size/diff_gen.rkt" 6 | "../size/size_log_sq_gen.rkt" 7 | (only-in tmonad bt_node bt_mt)))) 8 | 9 | (module copy racket 10 | (require "braun.rkt") 11 | 12 | (provide (all-defined-out)) 13 | 14 | (define (copy2 n) 15 | (cond 16 | [(zero? n) (values (mknode #f #f) #f)] 17 | [(odd? (- n 1)) 18 | (define-values (s t) (copy2 (/ (- n 2) 2))) 19 | (values (mknode s s) (mknode s t))] 20 | [(even? (- n 1)) 21 | (define-values (s t) (copy2 (/ (- n 1) 2))) 22 | (values (mknode s t) (mknode t t))])) 23 | 24 | (define/contract (copy n) 25 | (->i ([n natural-number/c]) 26 | [result (n) (λ (b) (= (size b) n))]) 27 | (define-values (s t) (copy2 n)) 28 | t) 29 | 30 | (module+ test 31 | (printf "testing braun tree invariants for copy\n") 32 | (for ([i (in-range 1000)]) (copy i)))) 33 | (require 'copy) 34 | 35 | (define (convert t) 36 | (cond 37 | [(node? t) (fp:bt_node (node-v t) 38 | (convert (node-l t)) 39 | (convert (node-r t)))] 40 | [else fp:bt_mt])) 41 | 42 | ;; computes the running time of diff 43 | (define/contract (diff-rt b m) 44 | ;; contract makes sure argument invariant holds 45 | (->i ([b (or/c node? #f)] 46 | [m (b) (λ (m) (<= m (size b) (+ m 1)))]) 47 | any) 48 | (define-values (result time) (fp:diff (convert b) m)) 49 | time) 50 | 51 | (define (non-zero? n) (not (= n 0))) 52 | 53 | (module+ test 54 | (printf "testing upper bound of running time of diff\n") 55 | (for ([n (in-range 10)]) 56 | (for ([m (in-list (list (- n 1) n))]) 57 | (when (positive? m) 58 | (define bt (copy n)) 59 | (define d (diff-rt bt m)) 60 | (define f (+ (* 13 (fl_log m)) 4)) 61 | (unless (<= d f) 62 | (eprintf "diff rt wrong: n = ~a m = ~a d = ~a f = ~a\n" n m d f)))))) 63 | 64 | 65 | (define (diff-rt-in-terms-of-m m) 66 | (cond 67 | [(zero? m) 4] 68 | [else (if (even? m) 69 | (+ 13 (diff-rt-in-terms-of-m (div2 (- m 2)))) 70 | (+ 11 (diff-rt-in-terms-of-m (div2 (- m 1)))))])) 71 | 72 | (module+ test 73 | (printf "testing exact running time of diff\n") 74 | (for ([n (in-range 1000)]) 75 | (for ([m (in-list (list (- n 1) n))]) 76 | (when (positive? m) 77 | (define bt (copy n)) 78 | (define d (diff-rt bt m)) 79 | (define f (diff-rt-in-terms-of-m m)) 80 | (unless (= d f) 81 | (eprintf "diff rt wrong: n = ~a m = ~a delta ~a\n" n m (- d f))))))) 82 | 83 | (define (size-rt-in-terms-of-bt-size n) 84 | (cond 85 | [(zero? n) 3] 86 | [else (+ (diff-rt-in-terms-of-m (div2 (- n 1))) 87 | (size-rt-in-terms-of-bt-size (div2 (- n 1))) 88 | 13)])) 89 | 90 | (module+ test 91 | (printf "testing exact running time of size\n") 92 | (for ([n (in-range 3000)]) 93 | (define bt (copy n)) 94 | (define d (loglog-size-rt bt)) 95 | (define f (size-rt-in-terms-of-bt-size n)) 96 | (unless (= d f) 97 | (eprintf "size rt wrong: n = ~a delta ~a\n" n (- d f))))) 98 | 99 | ;; compute the running time of the loglog-size function 100 | (define (loglog-size-rt b) 101 | (define-values (result time) (fp:size (convert b))) 102 | time) 103 | 104 | (define (sum-of-logs n) 105 | (cond 106 | [(zero? n) 3] 107 | [(odd? n) (+ (* 13 (fl_log n)) 17 (sum-of-logs (div2 (- n 1))))] 108 | [(even? n) (+ (* 13 (cl_log n)) 17 (sum-of-logs (div2 (- n 1))))])) 109 | 110 | (module+ test 111 | (printf "testing sum-of-logs\n") 112 | (for ([n (in-range 200)]) 113 | (define d (loglog-size-rt (copy n))) 114 | (define f (sum-of-logs n)) 115 | (unless (<= d f) 116 | (eprintf "size rt wrong: n = ~a d = ~a f = ~a\n" n d f)))) 117 | 118 | (define (sum-of-logs-ub n) (+ (* 17 (fl_log n) (fl_log n)) 20)) 119 | 120 | (module+ test 121 | (printf "testing upper bound of sum-of-logs\n") 122 | (let loop ([n 1] 123 | [i 400]) 124 | (unless (zero? i) 125 | (define ub (sum-of-logs-ub n)) 126 | (define sl (sum-of-logs n)) 127 | (unless (<= sl ub) 128 | (eprintf "upper bound wrong: n = ~a ub = ~a sl = ~a δ = ~a\n" 129 | n ub sl (- ub sl))) 130 | (loop (+ n n (random 100)) (- i 1))))) 131 | 132 | (module+ slideshow 133 | (require slideshow plot/pict "pict.rkt") 134 | 135 | (define (combine picts) 136 | (define width 800) 137 | (define gap 4) 138 | (define this-line '()) 139 | (define (finish) 140 | (apply ht-append gap (reverse this-line))) 141 | (let loop () 142 | (cond 143 | [(null? picts) 144 | (finish)] 145 | [else 146 | (define pict (car picts)) 147 | (cond 148 | [(< (pict-width pict) width) 149 | (set! this-line (cons pict this-line)) 150 | (set! width (- width (pict-width pict) gap)) 151 | (set! picts (cdr picts)) 152 | (loop)] 153 | [else 154 | (vl-append 10 155 | (finish) 156 | (combine picts))])]))) 157 | 158 | (slide 159 | (combine 160 | (for/list ([i (in-range 32)]) 161 | (tree->pict (copy i) #f)))) 162 | 163 | 164 | (define/contract (diff-path b m) 165 | ;; contract makes sure argument invariant holds 166 | (->i ([b (or/c node? #f)] 167 | [m (b) (λ (m) (<= m (size b) (+ m 1)))]) 168 | any) 169 | (match* (b m) 170 | [(#f 0) '()] 171 | [((node _ #f #f _) 0) '(l)] 172 | [((node _ s t _) (? (and/c odd? non-zero?))) 173 | (define k (/ (- m 1) 2)) 174 | (cons 'l (diff-path s k))] 175 | [((node _ s t _) (? (and/c even? non-zero?))) 176 | (define k (/ (- m 2) 2)) 177 | (cons 'r (diff-path t k))])) 178 | 179 | (slide 180 | #:title "diff's path, n=m case" 181 | (combine 182 | (for*/list ([n (in-range 32)]) 183 | (define b (copy n)) 184 | (define d (diff-path b n)) 185 | (tree->pict b d)))) 186 | 187 | (slide 188 | #:title "diff's path, n+1=m case" 189 | (combine 190 | (for*/list ([n (in-range 0 32)]) 191 | (define b (copy n)) 192 | (define d (diff-path b (max 0 (- n 1)))) 193 | (tree->pict b d)))) 194 | 195 | 196 | (define (plot-sum-of-logs upper-bound) 197 | (plot-pict 198 | #:x-label "n" 199 | #:y-label "sum_of_logs(n)" 200 | (lines 201 | (for/list ([i (in-range upper-bound)]) 202 | (vector i (sum-of-logs i)))))) 203 | 204 | (slide 205 | (scale-to-fit 206 | (vc-append 207 | (hc-append 208 | (plot-sum-of-logs (expt 2 8)) (plot-sum-of-logs (expt 2 9))) 209 | (hc-append 210 | (plot-sum-of-logs (expt 2 10)) (plot-sum-of-logs (expt 2 11)))) 211 | client-w client-h))) 212 | -------------------------------------------------------------------------------- /rkt/sub1-ex.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require (prefix-in : "../arith/sub1_gen.rkt") plot) 4 | 5 | (define (time-sub1-loop n) 6 | (let loop ([n n] 7 | [time-total 0]) 8 | (cond 9 | [(zero? n) time-total] 10 | [else 11 | (define-values (ans time) (:sub1 n)) 12 | ;; just make sure I didn't get the results in the wrong order 13 | (unless (= ans (- n 1)) (error 'ack)) 14 | (loop (- n 1) 15 | (+ time-total time))]))) 16 | 17 | (plot 18 | #:x-label "counting down from this number" 19 | #:y-label "abstract number of steps" 20 | (lines 21 | (for/list ([i (in-range 10000)]) 22 | (define the-time (time-sub1-loop i)) 23 | (define lb (- (* i 17) 16)) 24 | (define ub (* i 20)) 25 | (unless (<= lb the-time ub) 26 | (eprintf "~a: ~a ~a\n" i 27 | (- the-time lb) 28 | (- the-time ub))) 29 | (vector i the-time)))) 30 | 31 | -------------------------------------------------------------------------------- /rkt/sub1-plot.rkt: -------------------------------------------------------------------------------- 1 | #lang racket 2 | (require plot/pict 3 | (prefix-in : "../arith/sub1_gen.rkt") 4 | "sub1_linear.rkt" 5 | "sub1_div2.rkt" 6 | "copy_linear_sub1.rkt" 7 | "diff_sub1.rkt" 8 | "log.rkt") 9 | 10 | (provide plot-with-bound copy_linear_sub1_points copy_linear_sub1_bound) 11 | 12 | (define n 1000) 13 | (define logn 14 | ((log n) . / . (log 2))) 15 | (define (assert<=-linear n fn bound-fn) 16 | (for ([i (in-range n)]) 17 | (define lower (fn i)) 18 | (define higher (bound-fn i)) 19 | (unless (lower . <= . higher) 20 | (error "should be less but it ain't" i lower higher)))) 21 | 22 | (define (assert<=-log n fn bound-fn) 23 | (let loop 24 | ([i 0] 25 | [cur 1]) 26 | (define lower (fn cur)) 27 | (define higher (bound-fn cur)) 28 | (unless (lower . <= . higher) 29 | (error "should be less but it ain't" cur lower higher)) 30 | (unless (i . >= . n) 31 | (loop (+ i 1) 32 | (+ (random 100)(* 2 cur)))))) 33 | 34 | (define (plot-with-bound n mk-points bound-fn) 35 | (plot-pict 36 | (list 37 | (lines #:color 'darkgray 38 | (for/list ([i (in-range n)]) 39 | (vector i (bound-fn i)))) 40 | (mk-points n)))) 41 | 42 | (define (get-time fn x) 43 | (define-values (_ time) (fn x)) 44 | time) 45 | 46 | ;;;;;;;; sub1_linear 47 | ;; Bounded by linear 48 | ;; take/drop 49 | (define (sub1_linear_points n) 50 | (points 51 | (for/list ([i (in-range n)]) 52 | (vector i (get-time sub1_linear i))))) 53 | (define (sub1_linear_bound n) 54 | (10 . + . (40 . * . n))) 55 | (module+ main 56 | (plot-with-bound n sub1_linear_points sub1_linear_bound)) 57 | (module+ test 58 | (assert<=-linear n (curry get-time sub1_linear) sub1_linear_bound)) 59 | 60 | ;;;;;;;; sub1_div2 61 | ;; Bounded by a log 62 | ;; copy2, copy_insert 63 | (define (sub1_div2_points n) 64 | (points 65 | (for/list ([i (in-range n)]) 66 | (define-values (ans time) (sub1_div2 i)) 67 | (vector i time)))) 68 | (define (sub1_div2_bound n) 69 | (+ 20 (* 30 (fl_log n)))) 70 | 71 | (module+ main 72 | (plot-with-bound n sub1_div2_points sub1_div2_bound)) 73 | (module+ test 74 | (assert<=-log logn (curry get-time sub1_div2) sub1_div2_bound)) 75 | 76 | ;;;;;;;; diff 77 | ;; Bounded by log 78 | (define (diff_sub1_points n) 79 | (points 80 | (append 81 | (for/list ([i (in-range n)]) 82 | (define-values (ans time) (diff_sub1 i i)) 83 | (vector i time)) 84 | (for/list ([i (in-range n)]) 85 | (define-values (ans time) (diff_sub1 (+ 1 i) i)) 86 | (vector i time))))) 87 | (define (diff_sub1_different n) 88 | (define-values (_ t) (diff_sub1 (+ n 1) n)) 89 | t) 90 | (define (diff_sub1_same n) 91 | (define-values (_ t) (diff_sub1 n n)) 92 | t) 93 | (define (diff_sub1_bound n) 94 | (+ 3 (* 45 (fl_log n)))) 95 | (module+ main 96 | (plot-with-bound n diff_sub1_points diff_sub1_bound)) 97 | (module+ test 98 | (assert<=-log logn diff_sub1_same diff_sub1_bound) 99 | (assert<=-log logn diff_sub1_different diff_sub1_bound)) 100 | 101 | ;; Bounded by linear 102 | (define (copy_linear_sub1_points n) 103 | (lines 104 | (for/list ([i (in-range n)]) 105 | (define-values (ans time) (copy_linear_sub1 i)) 106 | (vector i time)))) 107 | 108 | (define (copy_linear_sub1_bound n) 109 | (+ 29 (n . * . 31))) 110 | (module+ main 111 | (plot-with-bound n copy_linear_sub1_points copy_linear_sub1_bound)) 112 | (module+ test 113 | (assert<=-linear n (curry get-time copy_linear_sub1) copy_linear_sub1_bound)) 114 | -------------------------------------------------------------------------------- /rkt/sub1_div2.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide sub1_div2) 3 | (require "../arith/sub1_gen.rkt") 4 | 5 | (Fixpoint 6 | sub1_div2 @n{nat} 7 | #:measure n 8 | #:returns @{nat} 9 | (match (n) 10 | [0 => (<== 0)] 11 | [(S _) 12 | => 13 | (bind ([nn (sub1 n)]) 14 | (bind ([pr (sub1_div2 (div2 nn))]) 15 | (<== pr)))])) 16 | -------------------------------------------------------------------------------- /rkt/sub1_linear.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "../arith/sub1_gen.rkt") 3 | (provide sub1_linear) 4 | 5 | (Fixpoint 6 | sub1_linear @n{nat} 7 | #:measure n 8 | #:returns @{nat} 9 | (match (n) 10 | [0 => (<== 0)] 11 | [(S _) 12 | => 13 | (bind ((nn (sub1 n))) 14 | (bind ((nnn (sub1_linear nn))) 15 | (<== 0)))])) 16 | -------------------------------------------------------------------------------- /rkt/sub1s.org: -------------------------------------------------------------------------------- 1 | 1. sub1, div2 (log I think); hypothesis: log overhead (3 + 6logn) 2 | 1. copy2 3 | 2. copy_insert 4 | 2. weird thing 5 | 1. copy_linear 6 | 3. weirder thing 7 | 1. diff 8 | 4. completely linear 9 | 1. drop/take 10 | 2. pad_drop 11 | 5. bad (actually not bad) addition (2m or 2m+1) 12 | 1. size_linear 13 | 6. ? addition (2m+1 or 2m+2) 14 | 1. size_log_sq 15 | -------------------------------------------------------------------------------- /rkt/tmonad/coq.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | 3 | (require parser-tools/lex 4 | parser-tools/yacc 5 | syntax/readerr 6 | racket/list 7 | (prefix-in : parser-tools/lex-sre)) 8 | 9 | (provide read-syntax read) 10 | 11 | (define (read port) 12 | (parse (object-name port) port)) 13 | (define (read-syntax name port) 14 | (parameterize ([current-mod-name (if (path? name) 15 | (let-values ([(base name dir?) (split-path name)]) 16 | (string->symbol 17 | (regexp-replace #rx"[.][^.]*$" (path->string name) ""))) 18 | 'anonymous-module)] 19 | [current-source name]) 20 | (datum->syntax #f (parse name port)))) 21 | 22 | (define (parse src port) 23 | (port-count-lines! port) 24 | (define (next-token) 25 | (parameterize ([current-source src]) 26 | (simple-coq-lexer port))) 27 | (ws-lexer port) 28 | (simple-coq-parser next-token)) 29 | 30 | (define-empty-tokens coq-empty-tokens 31 | (Program 32 | Fixpoint 33 | colon 34 | := 35 | period 36 | 37 | Provide 38 | 39 | brace-! !:! !! !-brace 40 | 41 | <- semicolon += <== 42 | 43 | match comma with pipe => end 44 | 45 | open-brace close-brace open-paren close-paren 46 | 47 | eof)) 48 | (define-tokens coq-tokens 49 | (id num)) 50 | 51 | (define-lex-abbrev ws (:* whitespace)) 52 | 53 | (define (ws-lexer port) 54 | (regexp-match #rx"[ \t\n]*" port)) 55 | 56 | (define simple-coq-lexer 57 | (lexer-src-pos 58 | [(:: "Provide" ws) (token-Provide)] 59 | [(:: "Program" ws) (token-Program)] 60 | [(:: "Fixpoint" ws) (token-Fixpoint)] 61 | [(:: "{" ws) (token-open-brace)] 62 | [(:: "}" ws) (token-close-brace)] 63 | [(:: "(" ws) (token-open-paren)] 64 | [(:: ")" ws) (token-close-paren)] 65 | [(:: ":=" ws) (token-:=)] 66 | [(:: ":" ws) (token-colon)] 67 | [(:: "." ws) (token-period)] 68 | [(:: "{!" ws) (token-brace-!)] 69 | [(:: "!:!" ws) (token-!:!)] 70 | [(:: "!!" ws) (token-!>!)] 72 | [(:: "!}" ws) (token-!-brace)] 73 | [(:: "<-" ws) (token-<-)] 74 | [(:: ";" ws) (token-semicolon)] 75 | [(:: "," ws) (token-comma)] 76 | [(:: "+=" ws) (token-+=)] 77 | [(:: "<==" ws) (token-<==)] 78 | [(:: "match" ws) (token-match)] 79 | [(:: "|" ws) (token-pipe)] 80 | [(:: "with" ws) (token-with)] 81 | [(:: "=>" ws) (token-=>)] 82 | [(:: "end" ws) (token-end)] 83 | [(:: (:+ "@" (:/ "a" "z" "A" "Z")) 84 | (:* (:+ "_" "'" (:/ "a" "z" "A" "Z" "0" "9"))) 85 | ws) 86 | (token-id (string->symbol 87 | (regexp-replace 88 | #rx"[\t\n ]*$" 89 | (regexp-replace* 90 | #rx"'" 91 | lexeme 92 | "′") 93 | "")))] 94 | [(:: (:/ "0" "9") (:* (:/ "0" "9")) ws) 95 | (token-num (string->number (regexp-replace #rx"[\t\n ]*$" lexeme "")))] 96 | ["(*" (begin (read-nested-comment 1 start-pos input-port) 97 | (ws-lexer input-port) 98 | (return-without-pos (simple-coq-lexer input-port)))] 99 | [(eof) (token-eof)] 100 | [(char-complement (union)) 101 | (raise-read-error 102 | (format "unknown character: ~a" lexeme) 103 | (current-source) 104 | (position-line start-pos) 105 | (position-col start-pos) 106 | (position-offset start-pos) 107 | 1)])) 108 | 109 | (define get-next-comment 110 | (lexer 111 | ["(*" (values 1 end-pos)] 112 | ["*)" (values -1 end-pos)] 113 | [(:or "*" ")" (:* (:~ "*" ")"))) 114 | (get-next-comment input-port)] 115 | [(eof) (values 'eof end-pos)] 116 | [(special) 117 | (get-next-comment input-port)] 118 | [(special-comment) 119 | (get-next-comment input-port)])) 120 | 121 | (define (read-nested-comment num-opens start-pos input) 122 | (let-values (((diff end) (get-next-comment input))) 123 | (cond 124 | ((eq? 'eof diff) (raise-read-error "eof in commments .... ")) 125 | (else 126 | (let ((next-num-opens (+ diff num-opens))) 127 | (cond 128 | ((= 0 next-num-opens) "") 129 | (else (read-nested-comment next-num-opens start-pos input)))))))) 130 | 131 | (define simple-coq-parser 132 | (parser 133 | (grammar 134 | [start ((defns) `(module ,(current-mod-name) tmonad/overly-specific ,@$1))] 135 | [defns 136 | ((defn) (list $1)) 137 | ((defn defns) (cons $1 $2))] 138 | [defn 139 | ((Program Fixpoint id args colon type := expr period) 140 | `(Fixpoint ,$3 ,@$4 #:returns (,$6) ,$8)) 141 | ((Provide id period) 142 | `(provide ,$2))] 143 | [args ((arg) $1) 144 | ((arg args) (append $1 $2))] 145 | [arg ((open-brace id colon type close-brace) 146 | `(#:implicit (,$2 ,$4))) 147 | ((open-paren id colon type close-paren) 148 | `((,$2 ,$4)))] 149 | [type ((ids) (apply string-append (add-between (map symbol->string $1) " ")))] 150 | [ids ((id) (list $1)) 151 | ((id ids) (cons $1 $2))] 152 | [expr-comma-list 153 | ((expr) (list $1)) 154 | ((expr comma expr-comma-list) 155 | (cons $1 $3))] 156 | [expr ((match expr-comma-list with match-cases end) 157 | `(match ,$2 ,@$4)) 158 | ((open-paren expr close-paren) $2) 159 | ((id <- expr semicolon expr) 160 | `(bind ((,$1 ,$3)) ,$5)) 161 | ((id) $1) 162 | ((num) $1) 163 | 164 | ;; application needs at least two ids (could be exprs --ack!) 165 | ((id ids) (cons $1 $2)) 166 | 167 | ((<== expr) `(<== ,$2))] 168 | [match-cases ((pipe pat => expr) 169 | (list `[,$2 => ,$4])) 170 | ((pipe pat => expr match-cases) 171 | (cons `[,$2 => ,$4] $5))] 172 | [pat ((id-or-nums) $1) 173 | ((open-paren pat close-paren) $2)] 174 | [id-or-nums ((id-or-num) (list $1)) 175 | ((id-or-num id-or-nums) (cons $1 $2))] 176 | [id-or-num ((id) $1) 177 | ((num) $1)]) 178 | 179 | (tokens coq-empty-tokens coq-tokens) 180 | (error 181 | (λ (tok-ok? tok-name tok-value start-pos end-pos) 182 | (raise-read-error 183 | (format "could not parse, starting from ~a at loc ~a" 184 | tok-name 185 | (position-offset start-pos)) 186 | (current-source) 187 | (position-line start-pos) 188 | (position-col start-pos) 189 | (position-offset start-pos) 190 | (- (position-offset end-pos) 191 | (position-offset start-pos))))) 192 | (end eof) 193 | (start start) 194 | (src-pos))) 195 | 196 | (define current-mod-name (make-parameter 'anonymous-module)) 197 | (define current-source (make-parameter #f)) 198 | -------------------------------------------------------------------------------- /rkt/tmonad/emit.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require racket/match 3 | racket/contract) 4 | 5 | (provide (struct-out Fp) 6 | (struct-out coq-arg) 7 | out-Fp 8 | out-prefix) 9 | 10 | (define (out-prefix name) 11 | (out "(* this file was generated automatically ") 12 | (when name 13 | (out "from ") 14 | (out name) 15 | (out " ")) 16 | (out "*)") 17 | (out-nl)) 18 | 19 | (struct Fp (name args measure result body)) 20 | (struct coq-arg (name string)) 21 | (define (out-Fp an-Fp) 22 | (match an-Fp 23 | [(Fp id args measure result body) 24 | (out "Program Fixpoint ") 25 | (out id) 26 | (for ([arg (in-list args)]) 27 | (out " ") 28 | (out (coq-arg-string arg))) 29 | (when measure 30 | (out " {measure ") 31 | (out measure) 32 | (out "}")) 33 | (out-nl) 34 | (out ": {! res !:! ") 35 | (out result) 36 | (out " !!") 37 | (out-nl) 38 | (out " ") 39 | (out id) 40 | (out "_result") 41 | (for ([i (in-list args)]) 42 | (out " ") 43 | (out (coq-arg-name i))) 44 | (out " res c !} :=") 45 | (indent 46 | 2 47 | (out-nl) 48 | (out-exp body #:already-delimited? #t) 49 | (out ".")) 50 | (out-nl)])) 51 | 52 | (define (out-exp exp #:already-delimited? [already-delimited? #f]) 53 | (define wrap-with-parens? (and (not already-delimited?) 54 | (not (simple? exp)))) 55 | (when wrap-with-parens? (out "(")) 56 | (indent 57 | (if wrap-with-parens? 1 0) 58 | (match exp 59 | [`(match (,texp1 ,texp2 ...) [,tsts1 ,tsts2 ... => ,rexps] ...) 60 | (out "match ") 61 | (out-exp texp1) 62 | (for ([texp (in-list texp2)]) 63 | (out ", ") 64 | (out-exp texp)) 65 | (out " with") 66 | (indent 67 | 2 68 | (for ([fst-tst (in-list tsts1)] 69 | [rst-tsts (in-list tsts2)] 70 | [rexp (in-list rexps)]) 71 | (out-nl) 72 | (out "| ") 73 | (out-pat fst-tst) 74 | (for ([rst-tst (in-list rst-tsts)]) 75 | (out ", ") 76 | (out-pat rst-tst)) 77 | (out " => ") 78 | (indent 2 79 | (out-nl) 80 | (out-exp rexp #:already-delimited? #t)))) 81 | (out-nl) 82 | (out "end")] 83 | [`(bind ([,xs ,es] ...) ,b) 84 | (for ([x (in-list xs)] 85 | [e (in-list es)]) 86 | (out-id x) 87 | (out " <- ") 88 | (indent (+ 4 (string-length (symbol->string x))) 89 | (out-exp e #:already-delimited? #t)) 90 | (out ";") 91 | (out-nl)) 92 | (out-exp b #:already-delimited? #t)] 93 | [`(same ,e1 ,e2) 94 | (out "same ") 95 | (out-exp e1) 96 | (indent 5 97 | (out-nl) 98 | (out-exp e2))] 99 | [`(if ,e1 ,e2 ,e3) 100 | (out "if ") 101 | (indent 3 (out-exp e1)) 102 | (out-nl) 103 | (out "then ") 104 | (indent 5 (out-exp e2)) 105 | (out-nl) 106 | (out "else ") 107 | (indent 5 (out-exp e3))] 108 | [(? symbol?) (out-id exp)] 109 | [(? number?) (out-const exp)] 110 | [`(<== ,e) 111 | (out "<== ") 112 | (indent 4 (out-exp e))] 113 | [`(+= ,k ,e) 114 | (out "+= ") 115 | (out k) 116 | (out "; ") 117 | (out-nl) 118 | (out-exp e #:already-delimited? #t)] 119 | [`(,(? infixop? fn) ,arg1 ,args ...) 120 | (out-exp arg1) 121 | (for ([arg (in-list args)]) 122 | (out " ") 123 | (out fn) 124 | (out " ") 125 | (out-exp arg))] 126 | [`(,(? symbol? fn) ,args ...) 127 | (out fn) 128 | (for ([arg (in-list args)]) 129 | (out " ") 130 | (out-exp arg))])) 131 | (when wrap-with-parens? (out ")"))) 132 | 133 | (define (infixop? x) (member x '(- + *))) 134 | (define (compound-expression? exp) (pair? exp)) 135 | (define (simple? exp) (or (symbol? exp) (number? exp))) 136 | (define (out-id id) 137 | (out (string->symbol (regexp-replace* #rx"′" (symbol->string id) "'")))) 138 | (define (out-const n) (out n)) 139 | 140 | (define-syntax-rule (indent n exp ...) 141 | (letrec ([_indentation indentation]) 142 | (set! indentation (+ indentation n)) 143 | exp ... 144 | (set! indentation _indentation))) 145 | 146 | (define indentation 0) 147 | (define (out-nl) 148 | (out "\n") 149 | (for ([_ (in-range indentation)]) 150 | (out " "))) 151 | (define (out s) (display s)) 152 | 153 | (define (out-pat exp) 154 | (define flat-pat? (or/c symbol? number?)) 155 | (match exp 156 | [`(,(? flat-pat?) ...) 157 | (for ([x (in-list exp)] 158 | [i (in-naturals)]) 159 | (unless (zero? i) (out " ")) 160 | (out-flat-pat x))] 161 | [(? flat-pat?) 162 | (out-flat-pat exp)])) 163 | 164 | (define (out-flat-pat exp) 165 | (if (symbol? exp) 166 | (out-id exp) 167 | (out exp))) 168 | -------------------------------------------------------------------------------- /rkt/tmonad/info.rkt: -------------------------------------------------------------------------------- 1 | #lang info 2 | (define collection "tmonad") 3 | (define deps '("base" "parser-tools-lib")) 4 | (define build-deps '()) 5 | -------------------------------------------------------------------------------- /rkt/tmonad/main.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require "private/the-lang.rkt") 3 | (provide (except-out 4 | (all-from-out 5 | "private/the-lang.rkt") 6 | overly-specific-Fixpoint)) -------------------------------------------------------------------------------- /rkt/tmonad/overly-specific.rkt: -------------------------------------------------------------------------------- 1 | #lang racket/base 2 | (require tmonad/private/the-lang) 3 | (provide (except-out 4 | (all-from-out 5 | tmonad/private/the-lang) 6 | Fixpoint)) 7 | (provide (rename-out [overly-specific-Fixpoint Fixpoint])) 8 | -------------------------------------------------------------------------------- /size/diff_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide diff) 4 | 5 | (Fixpoint 6 | diff #:implicit @A{Set} @b{@"@"bin_tree A} @m{nat} 7 | #:measure m 8 | #:returns @{nat} 9 | (match (b m) 10 | [(bt_mt) _ => (<== 0)] 11 | [(bt_node x _ _) 0 => (<== 1)] 12 | [(bt_node x s t) 13 | (S m′) 14 | => 15 | (if (even_odd_dec m) 16 | (bind ((o (diff t (div2 (- m′ 1))))) 17 | (<== o)) 18 | (bind ((o (diff s (div2 m′)))) 19 | (<== o)))])) 20 | -------------------------------------------------------------------------------- /size/size_linear.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.big_oh. 2 | Require Import Braun.common.braun Braun.common.util. 3 | Require Import Omega. 4 | 5 | Section size_linear. 6 | Variable A : Set. 7 | 8 | Definition size_linear_rt n : nat := 13 * n + 3. 9 | 10 | Definition size_linear_result (bt : @bin_tree A) (res:nat) c := 11 | c = size_linear_rt res /\ 12 | (forall m, 13 | Braun bt m -> 14 | m = res). 15 | 16 | (* the blank line above is important for the paper to build *) 17 | Load "size_linear_gen.v". 18 | 19 | Next Obligation. 20 | Proof. 21 | split; [auto |]. 22 | intros m B. 23 | invclr B. 24 | auto. 25 | Qed. 26 | 27 | Next Obligation. 28 | Proof. 29 | clear am0 H2 am H3. 30 | rename H0 into SLRr. 31 | rename H1 into SLRl. 32 | 33 | destruct SLRr as [XNeq Br]. 34 | destruct SLRl as [XN0eq Bl]. 35 | subst an an0. 36 | 37 | split. 38 | unfold size_linear_rt. 39 | omega. 40 | 41 | intros m B. 42 | invclr B. 43 | auto. 44 | Qed. 45 | 46 | Theorem size_linear_rt_is_linear : big_oh size_linear_rt (fun n => n). 47 | Proof. 48 | unfold size_linear_rt; auto. 49 | Qed. 50 | 51 | End size_linear. 52 | -------------------------------------------------------------------------------- /size/size_linear_bin.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad Braun.common.big_oh. 2 | Require Import Braun.common.braun Braun.common.util. 3 | Require Import Arith Arith.Even Arith.Div2 Omega. 4 | 5 | Section size_linear_bin. 6 | Variable A : Set. 7 | 8 | Definition size_linear_bin_rt n : nat := 17 * n + 3. 9 | 10 | Definition size_linear_bin_result (bt : @bin_tree A) (res:nat) c := 11 | forall m, 12 | Braun bt m -> 13 | c = size_linear_bin_rt res 14 | /\ m = res. 15 | 16 | (* the blank line above is important for the paper to build *) 17 | Definition same : 18 | forall {P Q R S:Prop}, 19 | (sumbool P Q) -> (sumbool R S) -> (P*R+Q*S) + (P*S+Q*R). 20 | Proof. 21 | intuition. 22 | Qed. 23 | 24 | Load "size_linear_bin_gen.v". 25 | 26 | Next Obligation. 27 | Proof. 28 | split; [auto |]. 29 | invclr H. 30 | auto. 31 | Qed. 32 | 33 | Next Obligation. 34 | Proof. 35 | clear am H4 am0 H3. 36 | rename H1 into SLBRr. 37 | rename H2 into SLBRl. 38 | rename H into EVENODD. 39 | 40 | unfold size_linear_bin_result in *. 41 | intros m B. 42 | invclr B. 43 | rename H2 into SIZE_INV. 44 | rename H4 into BL. 45 | rename H5 into BR. 46 | 47 | remember (SLBRr t_size) as INDr; clear HeqINDr SLBRr. 48 | apply INDr in BR. 49 | destruct BR; subst rs an. 50 | remember (SLBRl s_size) as INDl; clear HeqINDl SLBRl. 51 | apply INDl in BL. 52 | destruct BL; subst ls an0. 53 | clear INDl INDr. 54 | 55 | assert (s_size=t_size). 56 | 57 | apply braun_invariant_odd_size; auto. 58 | replace (s_size+t_size+1) with (S (s_size+t_size)) by omega. 59 | constructor. 60 | destruct EVENODD as [[EVEN_LS EVEN_RS]|[ODD_LS ODD_RS]]. 61 | apply even_even_plus; auto. 62 | apply odd_even_plus; auto. 63 | 64 | unfold double_plus1; unfold double; unfold size_linear_bin_rt. 65 | omega. 66 | Qed. 67 | 68 | Next Obligation. 69 | Proof. 70 | clear am H4 am0 H3. 71 | rename H1 into SLBRr. 72 | rename H2 into SLBRl. 73 | rename H into EVENODD. 74 | 75 | unfold size_linear_bin_result in *. 76 | intros m B. 77 | invclr B. 78 | rename H2 into SIZE_INV. 79 | rename H4 into BL. 80 | rename H5 into BR. 81 | remember (SLBRr t_size) as INDr; clear HeqINDr SLBRr. 82 | apply INDr in BR. 83 | destruct BR; subst rs an. 84 | remember (SLBRl s_size) as INDl; clear HeqINDl SLBRl. 85 | apply INDl in BL. 86 | destruct BL; subst ls an0. 87 | clear INDl INDr. 88 | 89 | assert (s_size=t_size+1). 90 | apply braun_invariant_even_size; auto. 91 | replace (s_size+t_size+1) with (S (s_size+t_size)) by omega. 92 | constructor. 93 | destruct EVENODD as [[EVEN_LS ODD_RS]|[ODD_LS EVEN_RS]]. 94 | apply odd_plus_r; auto. 95 | apply odd_plus_l; auto. 96 | 97 | unfold double_plus1; unfold double; unfold size_linear_bin_rt. 98 | omega. 99 | Qed. 100 | 101 | Theorem size_linear_rt_is_linear : big_oh size_linear_bin_rt (fun n => n). 102 | Proof. 103 | unfold size_linear_bin_rt; auto. 104 | Qed. 105 | 106 | End size_linear_bin. 107 | -------------------------------------------------------------------------------- /size/size_linear_bin_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide size_linear_bin) 4 | 5 | (Fixpoint 6 | size_linear_bin @bt{@"@"bin_tree A} 7 | #:returns @{nat} 8 | (match (bt) 9 | [(bt_mt) => (<== 0)] 10 | [(bt_node x l r) 11 | => 12 | (bind ([ls (size_linear_bin l)]) 13 | (bind ([rs (size_linear_bin r)]) 14 | (if (same (even_odd_dec ls) 15 | (even_odd_dec rs)) 16 | (<== (double_plus1 ls)) 17 | (<== (double ls)))))])) 18 | -------------------------------------------------------------------------------- /size/size_linear_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (Fixpoint 4 | size_linear @bt{@"@"bin_tree A} 5 | #:returns @{nat} 6 | (match (bt) 7 | [(bt_mt) => (<== 0)] 8 | [(bt_node x l r) 9 | => 10 | (bind ([ls (size_linear l)]) 11 | (bind ([rs (size_linear r)]) 12 | (<== (+ ls rs 1))))])) 13 | 14 | -------------------------------------------------------------------------------- /size/size_log_sq_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "diff_gen.rkt") 3 | (provide size) 4 | 5 | (Fixpoint 6 | size #:implicit @A{Set} @b{@"@"bin_tree A} 7 | #:returns @{nat} 8 | (match (b) 9 | [(bt_mt) => (<== 0)] 10 | [(bt_node _ s t) 11 | => 12 | (bind ((m (size t))) 13 | (bind ((zo (diff s m))) 14 | (<== (+ 1 (* 2 m) zo))))])) 15 | 16 | -------------------------------------------------------------------------------- /sort/clength_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide clength) 4 | (Fixpoint 5 | clength #:implicit @A{Set} @l{list A} 6 | #:returns @{nat} 7 | (match (l) 8 | [(nil) => (<== 0)] 9 | [(cons a′ l′) 10 | => 11 | (bind ((n′ (clength l′))) 12 | (<== (+ n′ 1)))])) 13 | 14 | -------------------------------------------------------------------------------- /sort/insert_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide insert) 4 | 5 | (Fixpoint 6 | insert #:implicit @A{Set} #:implicit @A_cmp{A -> A -> Prop} 7 | @A_cmp_trans{Transitive A_cmp} @A_cmp_total{Total A_cmp} 8 | @A_cmp_dec{DecCmp A_cmp} @a{A} @l{list A} 9 | #:returns @{list A} 10 | (match (l) 11 | [(nil) => (<== (cons a nil))] 12 | [(cons a′ l′) 13 | => 14 | (match ((A_cmp_dec a a′)) 15 | [(left _) => (<== (cons a l))] 16 | [(right _) 17 | => 18 | (bind ((res′ (insert A_cmp_trans A_cmp_total A_cmp_dec a l′))) 19 | (<== (cons a′ res′)))])])) 20 | -------------------------------------------------------------------------------- /sort/isort_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "insert_gen.rkt") 3 | 4 | (Fixpoint 5 | isort #:implicit @A{Set} #:implicit @A_cmp{A -> A -> Prop} 6 | @A_cmp_trans{Transitive A_cmp} @A_cmp_total{Total A_cmp} 7 | @A_cmp_dec{DecCmp A_cmp} @l{list A} 8 | #:returns @{list A} 9 | (match (l) 10 | [(nil) => (<== nil)] 11 | [(cons a d) 12 | => 13 | (bind ((d′ (isort A_cmp_trans A_cmp_total A_cmp_dec d))) 14 | (bind ((r′ (insert A_cmp_trans A_cmp_total A_cmp_dec a d′))) 15 | (<== r′)))])) 16 | -------------------------------------------------------------------------------- /sort/merge_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide merge) 4 | 5 | (Fixpoint 6 | merge #:implicit @A{Set} 7 | #:implicit @A_cmp{A -> A -> Prop} 8 | @A_cmp_trans{Transitive A_cmp} @A_cmp_total{Total A_cmp} @A_cmp_dec{DecCmp A_cmp} 9 | @xs{list A} @ys{list A} 10 | #:measure "(length (xs ++ ys))" 11 | #:returns @{list A} 12 | (match (xs) 13 | [(nil) => (<== ys)] 14 | [(cons x xs′) 15 | => 16 | (match (ys) 17 | [(nil) => (<== xs)] 18 | [(cons y ys′) 19 | => 20 | (match ((A_cmp_dec x y)) 21 | [(left _) 22 | => 23 | (bind ((res (merge A_cmp_trans A_cmp_total A_cmp_dec xs′ ys))) 24 | (<== (cons x res)))] 25 | [(right _) 26 | => 27 | (bind ((res (merge A_cmp_trans A_cmp_total A_cmp_dec xs ys′))) 28 | (<== (cons y res)))])])])) 29 | -------------------------------------------------------------------------------- /sort/mergesort_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "mergesortc_gen.rkt" "clength_gen.rkt") 3 | 4 | (Fixpoint 5 | mergesort #:implicit @A{Set} #:implicit @A_cmp{A -> A -> Prop} 6 | @A_cmp_trans{Transitive A_cmp} @A_cmp_total{Total A_cmp} 7 | @A_cmp_dec{DecCmp A_cmp} @l{list A} 8 | #:returns @{list A} 9 | (bind ((len (clength l))) 10 | (bind ((res (mergesortc A_cmp_trans A_cmp_total A_cmp_dec l len _))) 11 | (<== res)))) 12 | -------------------------------------------------------------------------------- /sort/mergesortc_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "split2_gen.rkt" 3 | "merge_gen.rkt" 4 | "insert_gen.rkt") 5 | 6 | (provide mergesortc) 7 | 8 | (Fixpoint 9 | mergesortc #:implicit @A{Set} #:implicit @A_cmp{A -> A -> Prop} 10 | @A_cmp_trans{Transitive A_cmp} @A_cmp_total{Total A_cmp} 11 | @A_cmp_dec{DecCmp A_cmp} @l{list A} @len{nat} @EQlen{len = length l} 12 | #:measure "(length l)" 13 | #:returns @{list A} 14 | (match (l) 15 | [(nil) => (<== nil)] 16 | [(cons x l′) 17 | => 18 | (if (even_odd_dec len) 19 | (bind ([xs12 (split2 (div2 len) l _)]) 20 | (bind ([xs1′ (mergesortc A_cmp_trans A_cmp_total A_cmp_dec 21 | (fst xs12) (div2 len) _)]) 22 | (bind ([xs2′ (mergesortc A_cmp_trans A_cmp_total A_cmp_dec 23 | (snd xs12) (div2 len) _)]) 24 | (bind ([res (merge A_cmp_trans A_cmp_total A_cmp_dec xs1′ xs2′)]) 25 | (<== res))))) 26 | (bind ([res′ (mergesortc A_cmp_trans A_cmp_total A_cmp_dec 27 | l′ (pred len) _)]) 28 | (bind ([res (insert A_cmp_trans A_cmp_total A_cmp_dec x res′)]) 29 | (<== res))))])) 30 | -------------------------------------------------------------------------------- /sort/sorting.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Sorting.Sorted Sorting.Permutation. 3 | 4 | Definition IsSorted {A:Set} (A_cmp:A -> A -> Prop) (l:list A) := 5 | (@StronglySorted A A_cmp l). 6 | 7 | Definition SortedOf {A:Set} (A_cmp:A -> A -> Prop) (l l':list A) := 8 | (@Permutation A l l') /\ 9 | (@IsSorted A A_cmp l'). 10 | 11 | Definition DecCmp {A:Set} (A_cmp:A -> A -> Prop) := 12 | forall x y, 13 | {A_cmp x y} + {~ A_cmp x y}. 14 | 15 | Definition Total {A:Set} (A_cmp:A -> A -> Prop) := 16 | forall x y, 17 | (~ A_cmp x y) -> 18 | A_cmp y x. 19 | 20 | Lemma Permutation_cons_step: 21 | forall A (a a':A) x y, 22 | Permutation (a :: x) y -> 23 | Permutation (a :: a' :: x) (a' :: y). 24 | Proof. 25 | intros. rename H into PM. 26 | eapply Permutation_trans. 27 | apply perm_swap. 28 | apply perm_skip. 29 | auto. 30 | Qed. 31 | 32 | -------------------------------------------------------------------------------- /sort/split2_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | 3 | (provide split2) 4 | 5 | (Fixpoint 6 | split2 #:implicit @A{Set} 7 | @n{nat} @l{list A} 8 | @V{n <= length l} 9 | #:returns @{((list A) * (list A))} 10 | (match (n) 11 | [0 => (<== (pair nil l))] 12 | [(S n′) 13 | => 14 | (match (l) 15 | [(nil) => (<== _)] 16 | [(cons a l′) 17 | => 18 | (bind ((res (split2 n′ l′ _))) 19 | (<== (pair (cons a (fst res)) (snd res))))])])) 20 | -------------------------------------------------------------------------------- /to_list/cinterleave_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide cinterleave) 3 | 4 | (Fixpoint 5 | cinterleave @A{Set} @e{list A} @o{list A} 6 | #:measure "(length (e ++ o))" 7 | #:returns @{list A} 8 | (match (e) 9 | [(nil) => (<== o)] 10 | [(cons x xs) => 11 | (bind ([xsp (cinterleave A o xs)]) 12 | (<== (cons x xsp)))])) 13 | -------------------------------------------------------------------------------- /to_list/to_list_naive.v: -------------------------------------------------------------------------------- 1 | Require Import Braun.monad.monad. 2 | 3 | Require Import Braun.common.sequence. 4 | Require Import Braun.common.list_util. 5 | 6 | Require Import Braun.common.braun. 7 | Require Import Braun.common.util. 8 | Require Import Braun.common.le_util. 9 | Require Import Braun.common.big_oh. 10 | Require Import Braun.common.pow. 11 | 12 | Require Import List Omega. 13 | 14 | Definition cinterleave_time_best (n:nat) (m:nat) := 15 | 3 + 9 * (min n m). 16 | Definition cinterleave_time_worst (n:nat) (m:nat) := 17 | 3 + 9 * (n + m). 18 | 19 | Definition cinterleave_result (A:Set) (e:list A) (o:list A) (xs:list A) (c:nat) := 20 | xs = interleave e o /\ 21 | cinterleave_time_best (length e) (length o) 22 | <= c <= cinterleave_time_worst (length e) (length o). 23 | 24 | Load "cinterleave_gen.v". 25 | 26 | Next Obligation. 27 | Proof. 28 | clear cinterleave. 29 | unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst. 30 | rewrite interleave_nil2. split. auto. 31 | simpl. omega. 32 | Qed. 33 | 34 | Next Obligation. 35 | Proof. 36 | clear cinterleave. 37 | unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst. 38 | simpl. rewrite app_length. rewrite app_length. omega. 39 | Qed. 40 | 41 | Next Obligation. 42 | Proof. 43 | clear cinterleave. 44 | unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst in *. 45 | clear am H1. 46 | rename H0 into REC_P. 47 | destruct REC_P as [EQ REC_P]. 48 | subst xsp. 49 | rewrite interleave_case2. split. auto. 50 | simpl length. 51 | replace (S (length xs) + length o) with (S (length o + length xs)); try omega. 52 | remember (length o + length xs) as L. 53 | rewrite Mult.mult_succ_r. 54 | rewrite Min.min_comm. 55 | destruct (Min.min_spec (length o) (length xs)) as [[LT EQ] | [LT EQ]]. 56 | rewrite EQ in REC_P. 57 | rewrite Min.min_l. omega. omega. 58 | rewrite EQ in REC_P. 59 | apply Min.min_case_strong; intros LE. 60 | omega. 61 | omega. 62 | Qed. 63 | 64 | Fixpoint tln_time n := 65 | match n with 66 | | O => 67 | 3 68 | | S n' => 69 | 15 + (3 + 9 * n') + 2 * tln_time n' 70 | end. 71 | 72 | Lemma tln_time_bigger: 73 | forall tn, 74 | 3 <= tln_time tn. 75 | Proof. 76 | induction tn as [|tn]; simpl; omega. 77 | Qed. 78 | 79 | Lemma tln_time_split: 80 | forall sn tn, 81 | tln_time sn + tln_time tn <= 2 * tln_time (sn + tn). 82 | Proof. 83 | induction sn as [|sn]; simpl; intros tn. 84 | remember (tln_time_bigger tn) as P. omega. 85 | 86 | assert (tln_time sn + tln_time tn <= 2 * tln_time (sn + tn)) as LE. 87 | auto. omega. 88 | Qed. 89 | 90 | Definition to_list_naive_result (A:Set) b (xs:list A) (c:nat) := 91 | SequenceR b xs 92 | /\ c <= tln_time (length xs). 93 | 94 | Load "to_list_naive_gen.v". 95 | 96 | Next Obligation. 97 | Proof. 98 | unfold to_list_naive_result. simpl. 99 | split. eauto. auto. 100 | Qed. 101 | 102 | Next Obligation. 103 | Proof. 104 | clear am0 H5 am1 H4. 105 | clear am H3. 106 | unfold to_list_naive_result in *. 107 | destruct H1 as [SEQt ANt]. 108 | destruct H2 as [SEQs ANs]. 109 | unfold cinterleave_result, cinterleave_time_best, cinterleave_time_worst in *. 110 | destruct H0 as [EQxs ANi]. 111 | subst xs. 112 | simpl length. 113 | rewrite <- interleave_length_split. 114 | remember (length sl) as sn. 115 | remember (length tl) as tn. 116 | split; eauto. 117 | clear SEQs SEQt A x s t sl tl Heqtn Heqsn. 118 | remember (an + 15) as p. 119 | replace (an1 + (an0 + p)) with 120 | (p + (an1 + an0)); try omega. 121 | replace (tln_time (S (sn + tn))) with 122 | (15 + (3 + 9 * (sn + tn)) + 2 * tln_time (sn + tn)); try auto. 123 | subst p. 124 | replace (an + 15 + (an1 + an0)) with (15 + an + (an0 + an1)); try omega. 125 | apply le_add. 126 | apply le_add. auto. omega. 127 | 128 | apply Le.le_trans with (tln_time sn + tln_time tn); try omega. 129 | apply tln_time_split. 130 | Qed. 131 | 132 | Theorem tln_time_big_oh: 133 | big_oh tln_time (fun n => pow 3 n). 134 | Proof. 135 | unfold big_oh. 136 | exists 0. exists 18. 137 | intros n _. generalize n. clear n. 138 | induction n as [|n]. 139 | simpl. omega. 140 | replace (tln_time (S n)) with (15 + (3 + 9 * n) + 2 * tln_time n); try auto. 141 | simpl pow. 142 | replace (18 * (pow 3 n + (pow 3 n + (pow 3 n + 0)))) 143 | with (18 * pow 3 n + 2 * 18 * pow 3 n); try omega. 144 | apply le_add. clear IHn. 145 | replace (15 + (3 + 9 * n)) with (9 * n + 18); try omega. 146 | 147 | induction n as [|n]. simpl. auto. 148 | simpl pow. rewrite Mult.mult_succ_r. 149 | replace (9 * n + 9 + 18) with (9 + (9 * n + 18)); try omega. 150 | rewrite <- Mult.mult_assoc. 151 | apply le_mult. auto. 152 | auto. 153 | Qed. 154 | -------------------------------------------------------------------------------- /to_list/to_list_naive_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "cinterleave_gen.rkt") 3 | 4 | (Fixpoint 5 | to_list_naive @A{Set} @b{@"@"bin_tree A} 6 | #:returns @{list A} 7 | (match (b) 8 | [(bt_mt) => (<== nil)] 9 | [(bt_node x s t) 10 | => 11 | (bind ([sl (to_list_naive A s)]) 12 | (bind ([tl (to_list_naive A t)]) 13 | (bind ([xs (cinterleave A sl tl)]) 14 | (<== (cons x xs)))))])) 15 | -------------------------------------------------------------------------------- /zippers/from_zip_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide from_zip) 3 | 4 | (Fixpoint 5 | from_zip 6 | @A{Set} @z{Zipper A} @ALL_RIGHT{(fst z) = nil} 7 | #:returns @{list A} 8 | (<== (snd z))) 9 | -------------------------------------------------------------------------------- /zippers/insert_at_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide insert_at) 3 | 4 | (Fixpoint 5 | insert_at 6 | @A{Set} @a{A} @n{nat} @l{list A} @NV{n <= length l} 7 | #:returns @{list A} 8 | (match (n) 9 | [O => 10 | (<== (cons a l))] 11 | [(S np) => 12 | (match (l) 13 | [(nil) => (<== _)] 14 | [(cons ap lp) => 15 | (bind ([resp (insert_at A a np lp _)]) 16 | (<== (cons ap resp)))])])) 17 | -------------------------------------------------------------------------------- /zippers/minsert_at_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "insert_at_gen.rkt") 3 | (provide minsert_at) 4 | 5 | (Fixpoint 6 | minsert_at 7 | @A{Set} @ma{list A} @n{nat} @l{list A} @NV{n <= length l} 8 | #:returns @{list A} 9 | (match (ma) 10 | [(nil) => (<== l)] 11 | [(cons a map) => 12 | (bind ([resp (insert_at A a n l NV)]) 13 | (bind ([respp (minsert_at A map n resp _)]) 14 | (<== respp)))])) 15 | -------------------------------------------------------------------------------- /zippers/minsertz_at_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "to_zip_gen.rkt" 3 | "zip_rightn_gen.rkt" 4 | "zip_minsert_gen.rkt" 5 | "zip_leftn_gen.rkt" 6 | "from_zip_gen.rkt") 7 | (provide minsertz_at) 8 | 9 | (Fixpoint 10 | minsertz_at 11 | @A{Set} @ma{list A} @n{nat} @l{list A} @NV{n <= length l} 12 | #:returns @{list A} 13 | (bind ([z (to_zip A l)]) 14 | (bind ([zr (zip_rightn A n z _)]) 15 | (bind ([zrp (zip_minsert A ma zr)]) 16 | (bind ([zp (zip_leftn A n zrp _)]) 17 | (bind ([lp (from_zip A zp _)]) 18 | (<== lp))))))) 19 | -------------------------------------------------------------------------------- /zippers/to_zip_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide to_zip) 3 | 4 | (Fixpoint 5 | to_zip 6 | @A{Set} @l{list A} 7 | #:returns @{Zipper A} 8 | (<== (pair nil l))) 9 | -------------------------------------------------------------------------------- /zippers/zip_insert_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide zip_insert) 3 | 4 | (Fixpoint 5 | zip_insert 6 | @A{Set} @z{Zipper A} @a{A} 7 | #:returns @{Zipper A} 8 | (<== (pair (fst z) (cons a (snd z))))) 9 | -------------------------------------------------------------------------------- /zippers/zip_left_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide zip_left) 3 | 4 | (Fixpoint 5 | zip_left 6 | @A{Set} @z{Zipper A} @SOME_LEFT{(fst z) <> nil} 7 | #:returns @{Zipper A} 8 | (match ((fst z)) 9 | [(nil) => (<== _)] 10 | [(cons b xs) => 11 | (<== (pair xs (cons b (snd z))))])) 12 | -------------------------------------------------------------------------------- /zippers/zip_leftn_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "zip_left_gen.rkt") 3 | (provide zip_leftn) 4 | 5 | (Fixpoint 6 | zip_leftn 7 | @A{Set} @n{nat} @z{Zipper A} @NV{n <= length (fst z)} 8 | #:returns @{Zipper A} 9 | (match (n) 10 | [O => (<== z)] 11 | [(S np) => 12 | (bind ([zp (zip_left A z _)]) 13 | (bind ([zpp (zip_leftn A np zp _)]) 14 | (<== zpp)))])) 15 | -------------------------------------------------------------------------------- /zippers/zip_minsert_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "zip_insert_gen.rkt") 3 | (provide zip_minsert) 4 | 5 | (Fixpoint 6 | zip_minsert 7 | @A{Set} @ma{list A} @z{Zipper A} 8 | #:returns @{Zipper A} 9 | (match (ma) 10 | [(nil) => (<== z)] 11 | [(cons a map) => 12 | (bind ([zp (zip_insert A z a)]) 13 | (bind ([zpp (zip_minsert A map zp)]) 14 | (<== zpp)))])) 15 | -------------------------------------------------------------------------------- /zippers/zip_right_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (provide zip_right) 3 | 4 | (Fixpoint 5 | zip_right 6 | @A{Set} @z{Zipper A} @SOME_RIGHT{(snd z) <> nil} 7 | #:returns @{Zipper A} 8 | (match ((snd z)) 9 | [(nil) => (<== _)] 10 | [(cons a ys) => 11 | (<== (pair (cons a (fst z)) ys))])) 12 | -------------------------------------------------------------------------------- /zippers/zip_rightn_gen.rkt: -------------------------------------------------------------------------------- 1 | #lang at-exp s-exp tmonad/overly-specific 2 | (require "zip_right_gen.rkt") 3 | (provide zip_rightn) 4 | 5 | (Fixpoint 6 | zip_rightn 7 | @A{Set} @n{nat} @z{Zipper A} @NV{n <= length (snd z)} 8 | #:returns @{Zipper A} 9 | (match (n) 10 | [O => (<== z)] 11 | [(S np) => 12 | (bind ([zp (zip_right A z _)]) 13 | (bind ([zpp (zip_rightn A np zp _)]) 14 | (<== zpp)))])) 15 | --------------------------------------------------------------------------------