├── .gitignore ├── .gitmodules ├── GUIDE.md ├── LICENSE ├── README.md └── plugin ├── _CoqProject ├── build.sh ├── coq ├── Indtype.v ├── Infrastructure.v ├── NoSmartCache.v ├── ShouldFail.v ├── SmartCache.v ├── Swap.v ├── Test.v ├── TestFindLift.v ├── TestLift.v ├── TestUnpack.v ├── examples │ ├── Assumptions.v │ ├── Example.v │ ├── Intro.v │ ├── Lift.v │ ├── LiftSpec.v │ ├── ListToVect.v │ ├── ListToVectCustom.v │ ├── Projections.v │ └── Search.v ├── handshake.v ├── minimal_records.v ├── more_records.v ├── nonorn.v ├── playground │ ├── Anders.v │ ├── add_constr.v │ ├── arbitrary.v │ ├── constr_extension.v │ ├── constr_refactor.v │ ├── defeq.v │ ├── elims.v │ ├── elims2.v │ ├── fin.v │ ├── flip.v │ ├── index_uip.v │ ├── refine_unit.v │ ├── sip.v │ └── trivial.v └── prod_rect.v ├── eval ├── Makefile ├── cast.v ├── equiv4free │ ├── Makefile │ ├── cast.v │ ├── lemmas.v │ ├── list.v │ ├── main.v │ ├── perm.v │ └── prepermutes.sh ├── lemmas.v ├── main.v ├── times.sed └── together.sh ├── src ├── automation │ ├── depelim.ml │ ├── depelim.mli │ ├── lift │ │ ├── lift.ml │ │ ├── lift.mli │ │ ├── liftconfig.ml │ │ ├── liftconfig.mli │ │ ├── liftrules.ml │ │ └── liftrules.mli │ ├── search │ │ ├── coherence.ml │ │ ├── coherence.mli │ │ ├── equivalence.ml │ │ ├── equivalence.mli │ │ ├── search.ml │ │ ├── search.mli │ │ ├── smartelim.ml │ │ └── smartelim.mli │ ├── unpack.ml │ └── unpack.mli ├── cache │ ├── caching.ml │ └── caching.mli ├── components │ ├── abstraction.ml │ ├── abstraction.mli │ ├── differencing.ml │ ├── differencing.mli │ ├── factoring.ml │ ├── factoring.mli │ ├── specialization.ml │ └── specialization.mli ├── frontend.ml ├── frontend.mli ├── lib │ ├── deltautils.ml │ ├── deltautils.mli │ ├── desugarprod.ml │ ├── desugarprod.mli │ ├── ornerrors.ml │ ├── ornerrors.mli │ ├── unificationutils.ml │ └── unificationutils.mli ├── options.ml ├── options.mli ├── ornamental.ml4 ├── ornaments.mlpack └── ornaments │ ├── lifting.ml │ ├── lifting.mli │ ├── promotion.ml │ └── promotion.mli ├── test.sh └── theories ├── Adjoint.v ├── Eliminators.v ├── Equivalences.v ├── Ornaments.v ├── Prod.v └── Unpack.v /.gitignore: -------------------------------------------------------------------------------- 1 | *.cmi 2 | *.cmo 3 | *.cmx 4 | *.cmt 5 | *.cmti 6 | *.mlpack.d 7 | *.o 8 | *.ml4.d 9 | *.cmxs 10 | *.coq.bak 11 | *.aux 12 | *.glob 13 | *.v.d 14 | *.vo 15 | *~ 16 | *.d 17 | *.cmxa 18 | *.a 19 | plugin/Makefile.coq.conf 20 | plugin/Makefile.coq 21 | plugin/Makefile.conf 22 | plugin/Makefile 23 | plugin/.merlin 24 | *.out 25 | _opam 26 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "plugin/src/coq-plugin-lib"] 2 | path = plugin/src/coq-plugin-lib 3 | url = https://github.com/uwplse/coq-plugin-lib.git 4 | [submodule "plugin/deps/fix-to-elim"] 5 | path = plugin/deps/fix-to-elim 6 | url = https://github.com/uwplse/fix-to-elim.git 7 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2019-2021 Talia Ringer, Nate Yazdani, RanDair Porter 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in 13 | all copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN 21 | THE SOFTWARE. 22 | -------------------------------------------------------------------------------- /plugin/_CoqProject: -------------------------------------------------------------------------------- 1 | -I src/coq-plugin-lib/src/utilities 2 | -I src/coq-plugin-lib/src/coq 3 | -I src/coq-plugin-lib/src/coq/termutils 4 | -I src/coq-plugin-lib/src/coq/constants 5 | -I src/coq-plugin-lib/src/coq/logicutils 6 | -I src/coq-plugin-lib/src/coq/logicutils/contexts 7 | -I src/coq-plugin-lib/src/coq/logicutils/typesandequality 8 | -I src/coq-plugin-lib/src/coq/logicutils/hofs 9 | -I src/coq-plugin-lib/src/coq/logicutils/inductive 10 | -I src/coq-plugin-lib/src/coq/logicutils/transformation 11 | -I src/coq-plugin-lib/src/coq/devutils 12 | -I src/coq-plugin-lib/src/coq/representationutils 13 | -I src/coq-plugin-lib/src/coq/decompiler 14 | -I src/ornaments 15 | -I src/cache 16 | -I src/components 17 | -I src/lib 18 | -I src/automation 19 | -I src/automation/search 20 | -I src/automation/lift 21 | -I src 22 | -R theories Ornamental 23 | 24 | src/coq-plugin-lib/src/utilities/utilities.ml 25 | src/coq-plugin-lib/src/utilities/utilities.mli 26 | 27 | src/coq-plugin-lib/src/coq/termutils/apputils.mli 28 | src/coq-plugin-lib/src/coq/termutils/apputils.ml 29 | src/coq-plugin-lib/src/coq/termutils/constutils.mli 30 | src/coq-plugin-lib/src/coq/termutils/constutils.ml 31 | src/coq-plugin-lib/src/coq/termutils/funutils.mli 32 | src/coq-plugin-lib/src/coq/termutils/funutils.ml 33 | 34 | src/coq-plugin-lib/src/coq/representationutils/defutils.mli 35 | src/coq-plugin-lib/src/coq/representationutils/defutils.ml 36 | src/coq-plugin-lib/src/coq/representationutils/nameutils.mli 37 | src/coq-plugin-lib/src/coq/representationutils/nameutils.ml 38 | 39 | src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.mli 40 | src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.ml 41 | src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.mli 42 | src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.ml 43 | src/coq-plugin-lib/src/coq/logicutils/typesandequality/checking.mli 44 | src/coq-plugin-lib/src/coq/logicutils/typesandequality/checking.ml 45 | 46 | src/coq-plugin-lib/src/coq/constants/equtils.mli 47 | src/coq-plugin-lib/src/coq/constants/equtils.ml 48 | src/coq-plugin-lib/src/coq/constants/sigmautils.mli 49 | src/coq-plugin-lib/src/coq/constants/sigmautils.ml 50 | src/coq-plugin-lib/src/coq/constants/produtils.mli 51 | src/coq-plugin-lib/src/coq/constants/produtils.ml 52 | src/coq-plugin-lib/src/coq/constants/idutils.mli 53 | src/coq-plugin-lib/src/coq/constants/idutils.ml 54 | src/coq-plugin-lib/src/coq/constants/proputils.mli 55 | src/coq-plugin-lib/src/coq/constants/proputils.ml 56 | 57 | src/coq-plugin-lib/src/coq/logicutils/contexts/stateutils.mli 58 | src/coq-plugin-lib/src/coq/logicutils/contexts/stateutils.ml 59 | src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.mli 60 | src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.ml 61 | src/coq-plugin-lib/src/coq/logicutils/contexts/contextutils.mli 62 | src/coq-plugin-lib/src/coq/logicutils/contexts/contextutils.ml 63 | 64 | src/coq-plugin-lib/src/coq/logicutils/hofs/hofs.mli 65 | src/coq-plugin-lib/src/coq/logicutils/hofs/hofs.ml 66 | src/coq-plugin-lib/src/coq/logicutils/hofs/hofimpls.mli 67 | src/coq-plugin-lib/src/coq/logicutils/hofs/hofimpls.ml 68 | src/coq-plugin-lib/src/coq/logicutils/hofs/debruijn.mli 69 | src/coq-plugin-lib/src/coq/logicutils/hofs/debruijn.ml 70 | src/coq-plugin-lib/src/coq/logicutils/hofs/substitution.mli 71 | src/coq-plugin-lib/src/coq/logicutils/hofs/substitution.ml 72 | src/coq-plugin-lib/src/coq/logicutils/hofs/reducers.mli 73 | src/coq-plugin-lib/src/coq/logicutils/hofs/reducers.ml 74 | src/coq-plugin-lib/src/coq/logicutils/hofs/typehofs.mli 75 | src/coq-plugin-lib/src/coq/logicutils/hofs/typehofs.ml 76 | src/coq-plugin-lib/src/coq/logicutils/hofs/zooming.mli 77 | src/coq-plugin-lib/src/coq/logicutils/hofs/zooming.ml 78 | src/coq-plugin-lib/src/coq/logicutils/hofs/hypotheses.mli 79 | src/coq-plugin-lib/src/coq/logicutils/hofs/hypotheses.ml 80 | 81 | src/coq-plugin-lib/src/coq/logicutils/inductive/indexing.mli 82 | src/coq-plugin-lib/src/coq/logicutils/inductive/indexing.ml 83 | src/coq-plugin-lib/src/coq/logicutils/inductive/indutils.mli 84 | src/coq-plugin-lib/src/coq/logicutils/inductive/indutils.ml 85 | 86 | src/coq-plugin-lib/src/coq/logicutils/contexts/modutils.mli 87 | src/coq-plugin-lib/src/coq/logicutils/contexts/modutils.ml 88 | 89 | src/coq-plugin-lib/src/coq/devutils/printing.mli 90 | src/coq-plugin-lib/src/coq/devutils/printing.ml 91 | 92 | src/coq-plugin-lib/src/coq/decompiler/decompiler.mli 93 | src/coq-plugin-lib/src/coq/decompiler/decompiler.ml 94 | 95 | deps/fix-to-elim/plugin/src/usability/preprocess_errors.mli 96 | deps/fix-to-elim/plugin/src/usability/preprocess_errors.ml 97 | 98 | src/lib/deltautils.ml 99 | src/lib/deltautils.mli 100 | src/lib/desugarprod.ml 101 | src/lib/desugarprod.mli 102 | src/lib/ornerrors.ml 103 | src/lib/ornerrors.mli 104 | src/lib/unificationutils.ml 105 | src/lib/unificationutils.mli 106 | 107 | src/ornaments/promotion.ml 108 | src/ornaments/promotion.mli 109 | 110 | src/cache/caching.ml 111 | src/cache/caching.mli 112 | 113 | src/ornaments/lifting.ml 114 | src/ornaments/lifting.mli 115 | 116 | src/components/factoring.ml 117 | src/components/factoring.mli 118 | src/components/abstraction.ml 119 | src/components/abstraction.mli 120 | src/components/specialization.ml 121 | src/components/specialization.mli 122 | src/components/differencing.ml 123 | src/components/differencing.mli 124 | 125 | src/options.ml 126 | src/options.mli 127 | 128 | src/automation/depelim.ml 129 | src/automation/depelim.mli 130 | src/automation/unpack.ml 131 | src/automation/unpack.mli 132 | 133 | src/automation/search/search.ml 134 | src/automation/search/search.mli 135 | src/automation/search/coherence.ml 136 | src/automation/search/coherence.mli 137 | src/automation/search/equivalence.ml 138 | src/automation/search/equivalence.mli 139 | src/automation/search/smartelim.ml 140 | src/automation/search/smartelim.mli 141 | 142 | src/automation/lift/liftconfig.ml 143 | src/automation/lift/liftconfig.mli 144 | src/automation/lift/liftrules.ml 145 | src/automation/lift/liftrules.mli 146 | src/automation/lift/lift.ml 147 | src/automation/lift/lift.mli 148 | 149 | src/frontend.ml 150 | src/frontend.mli 151 | src/ornamental.ml4 152 | src/ornaments.mlpack 153 | 154 | theories/Adjoint.v 155 | theories/Unpack.v 156 | theories/Prod.v 157 | theories/Eliminators.v 158 | theories/Equivalences.v 159 | theories/Ornaments.v 160 | -------------------------------------------------------------------------------- /plugin/build.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | git submodule init 3 | git submodule update 4 | echo "building dependencies" 5 | cd deps/fix-to-elim/plugin 6 | ./build.sh 7 | cd ../../.. 8 | echo "building DEVOID" 9 | 10 | coq_makefile -f _CoqProject -o Makefile 11 | make clean && make && make install 12 | 13 | -------------------------------------------------------------------------------- /plugin/coq/Indtype.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq". 2 | Require Import Ornamental.Ornaments. 3 | Require Import List Sorting.Permutation. 4 | Require Import Test TestLift. 5 | 6 | Notation "( x ; y )" := (existT _ x y) (no associativity). 7 | Notation "p .1" := (projT1 p) (left associativity, at level 8, format "p .1"). 8 | Notation "p .2" := (projT2 p) (left associativity, at level 8, format "p .2"). 9 | Notation "p .&" := (p.1; p.2) (left associativity, at level 6, format "p .&"). 10 | 11 | Notation hdV := hd_vect_lifted. 12 | Notation tlV := tl_vect_lifted. 13 | 14 | Definition length {A : Type} (xs : list A) : nat := 15 | list_rect 16 | (fun _ => nat) 17 | O 18 | (fun _ _ n => S n) 19 | xs. 20 | Lift list vector in @length as lengthV. 21 | 22 | (* Ex. 1: Promoting append relation from lists to vectors *) 23 | Section Append. 24 | 25 | Inductive is_app {A : Type} : list A -> list A -> list A -> Type := 26 | | is_app_cons (x : A) (xs ys zs : list A) : 27 | is_app xs ys zs -> 28 | is_app (x :: xs) ys (x :: zs) 29 | | is_app_nil (ys : list A) : 30 | is_app nil ys ys. 31 | Lift list vector in @is_app as ..V. 32 | 33 | (* Does the lifted type former have the expected type? *) 34 | Example check_is_appV 35 | : forall (A : Type) (xs ys zs : {n:nat & vector A n}), Type := 36 | is_appV. 37 | 38 | (* Does the lifted constructor for is_app_cons have the expected type? *) 39 | Example check_is_app_consV 40 | : forall (A : Type) (x : A) (xs ys zs : {n:nat & vector A n}), 41 | is_appV A xs.& ys.& zs.& -> 42 | is_appV A 43 | (S xs.1; consV A xs.1 x xs.2) 44 | ys.& 45 | (S zs.1; consV A zs.1 x zs.2) := 46 | is_app_consV. 47 | 48 | (* Does the lifted constructor for is_app_nil have the expected type? *) 49 | Example check_is_app_nilV 50 | : forall (A : Type) (ys : {n:nat & vector A n}), 51 | is_appV A (O; nilV A) ys.& ys.& := 52 | is_app_nilV. 53 | 54 | (* Get the size of an is_app proof. *) 55 | Definition is_app_size {A : Type} (xs ys zs : list A) (H : is_app xs ys zs) : nat := 56 | is_app_rect 57 | A 58 | (fun _ _ _ _ => nat) 59 | (fun _ _ _ _ _ IH => S IH) 60 | (fun _ => O) 61 | xs ys zs 62 | H. 63 | Lift list vector in @is_app_size as is_appV_size. 64 | 65 | Lemma is_app_size_len {A : Type} (xs ys zs : list A) (H : is_app xs ys zs) : 66 | is_app_size xs ys zs H = length xs. 67 | Proof. 68 | induction H; simpl; try rewrite IHis_app; reflexivity. 69 | Defined. 70 | Lift list vector in @is_app_size_len as is_appV_size_len. 71 | 72 | Lemma is_app_len {A : Type} (xs ys zs : list A) : 73 | is_app xs ys zs -> length xs + length ys = length zs. 74 | Proof. 75 | intro H. induction H; simpl. 76 | - rewrite IHis_app. reflexivity. 77 | - reflexivity. 78 | Defined. 79 | Lift list vector in @is_app_len as is_appV_len. 80 | 81 | Lemma is_app_tl (A : Type) (xs ys zs : list A) : 82 | is_app xs ys zs -> 83 | is_app (tl A xs) ys (match xs with cons _ _ => (tl A zs) | nil => zs end). 84 | Proof. 85 | intro H. induction H; simpl. 86 | - assumption. 87 | - constructor. 88 | Defined. 89 | Preprocess is_app_tl as is_app_tl'. 90 | Lift list vector in is_app_tl' as is_appV_tl. 91 | 92 | Lemma is_app_uncons (A : Type) (x : A) (xs ys zs : list A) : 93 | is_app (x :: xs) ys (x :: zs) -> is_app xs ys zs. 94 | Proof. 95 | remember (x :: xs) as xs' eqn:Exs. remember (x :: zs) as zs' eqn:Ezs. 96 | intro H. destruct H. 97 | - inversion Exs. inversion Ezs. rewrite H2, H4 in H. assumption. 98 | - inversion Exs. 99 | Defined. 100 | Preprocess is_app_uncons as is_app_uncons'. 101 | Lift list vector in is_app_uncons' as is_appV_uncons { opaque eq_rect_r }. 102 | 103 | End Append. 104 | 105 | (* Ex. 2: Promoting permutation relation from lists to vectors *) 106 | Section Permute. 107 | 108 | Inductive perm {A : Type} : list A -> list A -> Type := 109 | | perm_nil : 110 | perm nil nil 111 | | perm_skip (x : A) (xs ys : list A) : 112 | perm xs ys -> 113 | perm (x :: xs) 114 | (x :: ys) 115 | | perm_swap (x y : A) (xs : list A) : 116 | perm (x :: y :: xs) 117 | (y :: x :: xs) 118 | | perm_trans (xs ys zs : list A) : 119 | perm xs ys -> perm ys zs -> perm xs zs. 120 | Lift list vector in @perm as ..V. 121 | 122 | (* Does the lifted type former have the expected type? *) 123 | Example check_permV 124 | : forall (A : Type) (xs ys : {n:nat & vector A n}), Type := 125 | permV. 126 | 127 | (* Does the lifted constructor for perm_nil have the expected type? *) 128 | Example check_perm_nilV 129 | : forall (A : Type), permV A (O; nilV A) (O; nilV A) := 130 | perm_nilV. 131 | 132 | (* Does the lifted constructor for perm_skip have the expected type? *) 133 | Example check_perm_skipV 134 | : forall (A : Type) (x : A) (xs ys : {n:nat & vector A n}), 135 | permV A xs.& ys.& -> 136 | permV A 137 | (S xs.1; consV A xs.1 x xs.2) 138 | (S ys.1; consV A ys.1 x ys.2) := 139 | perm_skipV. 140 | 141 | (* Does the lifted constructor for perm_swap have the expected type? *) 142 | Example check_perm_swapV 143 | : forall (A : Type) (x y : A) (xs : {n:nat & vector A n}), 144 | permV A 145 | (S (S xs.1); consV A (S xs.1) x (consV A xs.1 y xs.2)) 146 | (S (S xs.1); consV A (S xs.1) y (consV A xs.1 x xs.2)) := 147 | perm_swapV. 148 | 149 | (* Does the lifted constructor for perm_trans have the expected type? *) 150 | Example check_perm_transV 151 | : forall (A : Type) (xs ys zs : {n:nat & vector A n}), 152 | permV A xs.& ys.& -> permV A ys.& zs.& -> permV A xs.& zs.& := 153 | perm_transV. 154 | 155 | (* Get the size of a perm proof. *) 156 | Definition perm_size {A : Type} (xs ys : list A) (H : perm xs ys) : nat := 157 | perm_rect 158 | A 159 | (fun _ _ _ => nat) 160 | O 161 | (fun _ _ _ _ IH => S IH) 162 | (fun _ _ _ => O) 163 | (fun _ _ _ _ IH_l _ IH_r => S (IH_l + IH_r)) 164 | xs ys H. 165 | Lift list vector in @perm_size as permV_size. 166 | 167 | Lemma perm_len {A : Type} (xs ys : list A) : 168 | perm xs ys -> length xs = length ys. 169 | Proof. 170 | intro H. induction H; simpl. 171 | - reflexivity. 172 | - rewrite IHperm. reflexivity. 173 | - reflexivity. 174 | - eapply eq_trans; eauto. 175 | Defined. 176 | Lift list vector in @perm_len as permV_len. 177 | 178 | End Permute. 179 | -------------------------------------------------------------------------------- /plugin/coq/Infrastructure.v: -------------------------------------------------------------------------------- 1 | (* 2 | * This file contains test infrastructure. 3 | *) 4 | 5 | (* 6 | * Test exact equality of goals (rather than 7 | * definitional equality). That way, we can test 8 | * that a specific term is produced that is syntactically 9 | * friendly to the user, for example using certain 10 | * constants. 11 | *) 12 | Ltac test_exact_equality := 13 | match goal with 14 | | |- ?x = ?x => reflexivity 15 | | _ => idtac 16 | end. -------------------------------------------------------------------------------- /plugin/coq/NoSmartCache.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq". 2 | Require Import Ornamental.Ornaments. 3 | Require Import List. 4 | Require Import minimal_records. 5 | Require Import Coq.Bool.Bool. 6 | 7 | Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *) 8 | Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *) 9 | Set Nonrecursive Elimination Schemes. (* <--- Preprocess needs induction principles for records *) 10 | Unset DEVOID smart cache. (* <-- Disable the smart cache! *) 11 | 12 | Module leb. 13 | 14 | Lemma leb_implb : forall b1 b2, leb b1 b2 -> implb b1 b2 = true. 15 | Proof. 16 | apply leb_implb. 17 | Qed. 18 | 19 | End leb. 20 | 21 | Preprocess Module leb as leb' { opaque Bool.leb_implb }. 22 | Definition leb_implb := leb'.leb_implb. 23 | 24 | Definition f (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (andb b1 (orb b2 (xorb b3 b4)))) true) false b4. 25 | Definition g (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (orb b1 (andb b2 (xorb b3 b4)))) true) false b4. 26 | Definition h (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (orb (andb b1 b2) (xorb b3 b4))) true) false b4. 27 | Definition i (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (andb (orb b1 b2) (xorb b3 b4))) true) false b4. 28 | 29 | Time Lift Generated'.output Handwritten'.output in f as f'. 30 | Time Lift Generated'.output Handwritten'.output in g as g'. 31 | Time Lift Generated'.output Handwritten'.output in h as h'. 32 | Time Lift Generated'.output Handwritten'.output in i as i'. 33 | 34 | Lemma test_f : 35 | f = f'. 36 | Proof. 37 | reflexivity. 38 | Qed. 39 | 40 | Lemma test_g : 41 | g = g'. 42 | Proof. 43 | reflexivity. 44 | Qed. 45 | 46 | Lemma test_h : 47 | h = h'. 48 | Proof. 49 | reflexivity. 50 | Qed. 51 | 52 | Lemma test_i : 53 | i = i'. 54 | Proof. 55 | reflexivity. 56 | Qed. 57 | 58 | -------------------------------------------------------------------------------- /plugin/coq/ShouldFail.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | Require Import Ornamental.Ornaments. 3 | Require Import Test. 4 | 5 | (* 6 | * Bellow are other kinds of changes I have tried that are not 7 | * yet supported. 8 | *) 9 | 10 | (* --- Balanced binary trees --- *) 11 | 12 | Inductive bal_bintree (A : Type) : nat -> Type := 13 | | bal_leaf : 14 | bal_bintree A 0 15 | | bal_node : 16 | forall (n : nat), 17 | bal_bintree A n -> A -> bal_bintree A n -> bal_bintree A (n + n). 18 | 19 | (* 20 | * This technically works for indexing, 21 | * but has an extra condition we don't find yet: 22 | * 23 | * Find ornament bintree bal_bintree as bintree_balancer. 24 | * 25 | * Print bintree_balancer_index. 26 | * 27 | * That is, we can find an indexing function, but note that to use it 28 | * (and to port bintrees to bal_bintrees anyways) we need a balanced 29 | * premise. We should be able to also infer the balanced premise automatically, 30 | * but it's tricky to know when we actually need to do this. 31 | * It seems like when the same index is referenced by several of the 32 | * other bintrees. We should revisit this at some point. 33 | *) 34 | 35 | (* --- Nat and fin --- *) 36 | 37 | (* 38 | * Not sure if possible, but might as well try. 39 | * 40 | * This doesn't work, though it's technically possible because (n : nat) 41 | * is our original type. I think we should consider this separately from 42 | * standard indexing though. 43 | * 44 | * See git history prior to 2/14 for some attempts at this that might 45 | * be useful for later on. 46 | * 47 | * Inductive fin : nat -> Type := 48 | * | F1 : forall (n : nat), fin (S n) 49 | * | FS : forall (n : nat), fin n -> fin (S n). 50 | * 51 | * Find ornament nat fin as orn_nat_fin. 52 | * 53 | * Definition nat_fin_index (n : nat) := 54 | * nat_ind 55 | * (fun (n : nat) => nat) 56 | * (S O) 57 | * (fun (n : nat) (IH : nat) => S IH) 58 | * n. 59 | *) 60 | 61 | (* --- Vectors using multiple nats --- *) 62 | 63 | (* 64 | * If we add another nat to this hypothesis, then we have something incompletely 65 | * determined, because we need an extra nat in each case. 66 | *) 67 | 68 | Inductive vector3 (A : Type) : nat -> Type := 69 | | nilV3 : vector3 A 0 70 | | consV3 : forall (n m : nat), A -> vector3 A n -> vector3 A (n + m). 71 | 72 | (* 73 | * This will fail (as it should, for now, though with a better error): 74 | * 75 | * Find ornament list vector3 as orn_list_vector3. 76 | * 77 | * Print orn_list_vector3_index. 78 | *) 79 | 80 | Inductive vector4 (A : Type) : nat -> Type := 81 | | nilV4 : vector4 A 0 82 | | consV4 : forall (n m : nat), A -> vector4 A (n + m) -> vector4 A n. 83 | 84 | (* 85 | * This will fail (as it should, for now, though with a better error): 86 | * 87 | * Find ornament list vector4 as orn_list_vector4. 88 | * 89 | * Print orn_list_vector4_index. 90 | *) 91 | 92 | (* --- Index is computed from a hypothesis with a different type --- *) 93 | 94 | Require Import ZArith. 95 | 96 | Inductive vector_int (A : Type) : Z -> Type := 97 | | nilV_int : vector_int A (Z.of_nat 0) 98 | | consV_int : 99 | forall (n : nat), 100 | A -> vector_int A (Z.of_nat n) -> vector_int A (Z.of_nat (S n)). 101 | 102 | Require Import Test. 103 | 104 | Theorem vector_int_index: 105 | forall (A : Type) (n : nat), 106 | vector A n -> 107 | Z. 108 | Proof. 109 | intros. induction X. 110 | - apply (Z.of_nat 0). 111 | - apply Z.of_nat. apply (S n). 112 | Qed. 113 | 114 | (* 115 | * This fails: 116 | * Find ornament list vector_int as orn_list_vectorint. 117 | * 118 | * For this to pass, we really need to chain it with PUMPKIN, because what 119 | * is happening is we first need to find the patch that gets us from list 120 | * to vector, and then we need to get from that indexing function 121 | * to Z by searching for a patch. This is really cool. 122 | * 123 | * An alternative approach is to get the function that gets us back from 124 | * Z to nat, so that we can make use of the inductive hypothesis. 125 | * But that is much less clear to me. 126 | *) 127 | 128 | (* --- Index must be eliminated --- *) 129 | 130 | Inductive bintree_weird (A : Type) : nat -> Type := 131 | | leafW : 132 | bintree_weird A 0 133 | | nodeW : 134 | forall (n m : nat), 135 | bintree_weird A n -> A -> bintree_weird A (n + m) -> bintree_weird A n. 136 | 137 | (* 138 | * This fails: 139 | * Find ornament bintree bintree_weird as orn_bintree_bintreeweird. 140 | * 141 | * Basically, we can't figure out the conclusion from the hypotheses 142 | * since there's no way to eliminate (n + m) automatically. 143 | *) 144 | -------------------------------------------------------------------------------- /plugin/coq/SmartCache.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq". 2 | Require Import Ornamental.Ornaments. 3 | Require Import List. 4 | Require Import minimal_records. 5 | Require Import Coq.Bool.Bool. 6 | 7 | Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *) 8 | Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *) 9 | Set Nonrecursive Elimination Schemes. (* <--- Preprocess needs induction principles for records *) 10 | Set DEVOID smart cache. 11 | 12 | Module leb. 13 | 14 | Lemma leb_implb : forall b1 b2, leb b1 b2 -> implb b1 b2 = true. 15 | Proof. 16 | apply leb_implb. 17 | Qed. 18 | 19 | End leb. 20 | 21 | Preprocess Module leb as leb' { opaque Bool.leb_implb }. 22 | Definition leb_implb := leb'.leb_implb. 23 | 24 | Definition f (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (andb b1 (orb b2 (xorb b3 b4)))) true) false b4. 25 | Definition g (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (orb b1 (andb b2 (xorb b3 b4)))) true) false b4. 26 | Definition h (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (orb (andb b1 b2) (xorb b3 b4))) true) false b4. 27 | Definition i (b1 b2 b3 b4 : bool) (H : leb true false) (H0 : leb_implb true false H = leb_implb true false H) := ifb (eqb (negb (andb (orb b1 b2) (xorb b3 b4))) true) false b4. 28 | 29 | Time Lift Generated'.output Handwritten'.output in f as f'. 30 | Time Lift Generated'.output Handwritten'.output in g as g'. 31 | Time Lift Generated'.output Handwritten'.output in h as h'. 32 | Time Lift Generated'.output Handwritten'.output in i as i'. 33 | 34 | Lemma test_f : 35 | f = f'. 36 | Proof. 37 | reflexivity. 38 | Qed. 39 | 40 | Lemma test_g : 41 | g = g'. 42 | Proof. 43 | reflexivity. 44 | Qed. 45 | 46 | Lemma test_h : 47 | h = h'. 48 | Proof. 49 | reflexivity. 50 | Qed. 51 | 52 | Lemma test_i : 53 | i = i'. 54 | Proof. 55 | reflexivity. 56 | Qed. 57 | -------------------------------------------------------------------------------- /plugin/coq/TestFindLift.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq". 2 | Require Import List. 3 | Require Import Ornamental.Ornaments. 4 | 5 | (* 6 | * This file tests automatically running 7 | * Find Ornament on the first invocation of Lift. 8 | * For it to work, both Find Ornament and Lift need to work. 9 | * The difference between this and the relevant part of TestLift.v 10 | * is that this does not import Test, which has the relevant Find Ornament commands. 11 | *) 12 | 13 | (* --- Simple constructor tests ---- *) 14 | 15 | Inductive vector (A : Type) : nat -> Type := 16 | | nilV : vector A 0 17 | | consV : forall (n : nat), A -> vector A n -> vector A (S n). 18 | 19 | Definition packed_vector (T : Type) := 20 | sigT (fun (n : nat) => vector T n). 21 | 22 | Definition nil' := @nil. 23 | 24 | Lift list vector in nil' as nil'_c. 25 | Theorem testNil: 26 | forall A, nil'_c A = existT (vector A) 0 (nilV A). 27 | Proof. 28 | intros. reflexivity. 29 | Qed. 30 | 31 | Definition nilV' (A : Type) := 32 | existT (vector A) 0 (nilV A). 33 | 34 | Lift vector list in nilV' as nilV'_c. 35 | Theorem testNilV: 36 | forall A, nilV'_c A = @nil A. 37 | Proof. 38 | intros. reflexivity. 39 | Qed. 40 | 41 | Definition cons' := @cons. 42 | 43 | Lift list vector in cons' as cons'_c. 44 | Theorem testCons: 45 | forall A a pv, 46 | cons'_c A a pv = 47 | existT (vector A) (S (projT1 pv)) (consV A (projT1 pv) a (projT2 pv)). 48 | Proof. 49 | intros. reflexivity. 50 | Qed. 51 | 52 | Lift vector list in cons'_c as consV'_c. 53 | Theorem testConsV: 54 | forall A a l, 55 | consV'_c A a l = @cons A a l. 56 | Proof. 57 | intros. reflexivity. 58 | Qed. 59 | -------------------------------------------------------------------------------- /plugin/coq/TestUnpack.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Basic lifting tests for unpack, building on TestLift.v 3 | *) 4 | 5 | Add LoadPath "coq". 6 | Require Import Vector. 7 | Require Import List. 8 | Require Import Test. 9 | Require Import TestLift. 10 | Require Import Ornamental.Ornaments. 11 | Require Import Infrastructure. 12 | 13 | Set DEVOID lift type. 14 | 15 | Definition packed_list_rect := Test.orn_list_vector_rect. 16 | Definition length {T} l := list_to_vector_index T l. 17 | Definition packed T n := { s : sigT (vector T) & projT1 s = n}. 18 | 19 | (* --- Simple constructor tests ---- *) 20 | 21 | Program Definition nilp (T : Type): 22 | { l : list T & length l = 0 }. 23 | Proof. 24 | exists (nil' T). (* lists *) 25 | reflexivity. (* lengths *) 26 | Defined. 27 | 28 | Lift list vector in nilp as nilpv. 29 | Lift packed vector in nilpv as nilV. 30 | 31 | Theorem testNil: 32 | nilV = Test.nilV. 33 | Proof. 34 | reflexivity. 35 | Qed. 36 | 37 | (* Uncached *) 38 | Definition nilV' (A : Type) := Test.nilV A. 39 | 40 | Lift vector packed in nilV' as nilpv'. 41 | Lift vector list in nilpv' as nilp'. 42 | 43 | Theorem testNilV: 44 | forall A, nilp' A = nilp A. 45 | Proof. 46 | intros. reflexivity. 47 | Qed. 48 | 49 | (* Cached *) 50 | Lift vector packed in nilV as nilpv''. 51 | Lift vector list in nilpv'' as nilp''. 52 | 53 | Theorem testNilV_cached: 54 | forall A, nilp'' A = nilp A. 55 | Proof. 56 | intros. reflexivity. 57 | Qed. 58 | 59 | Program Definition consp (T : Type) (n : nat) (t : T): 60 | { l : list T & length l = n} -> 61 | { l : list T & length l = S n }. 62 | Proof. 63 | intros. apply packed_list_rect with (P := fun (_ : { l : list T & length l = n }) => { l : list T & length l = S n}). 64 | - intros. exists (cons t a). (* lists *) 65 | simpl. rewrite <- H. reflexivity. (* lengths *) 66 | - apply X. 67 | Defined. 68 | 69 | Lift list vector in consp as conspv. 70 | Lift packed vector in conspv as consV. 71 | 72 | Theorem testCons: 73 | consV = Test.consV. 74 | Proof. 75 | reflexivity. 76 | Qed. 77 | 78 | (* 79 | * Uncached. 80 | * This fails because Algebraic is not smart enough to understand that it should 81 | * lift (eq_refl (S n) : projT1 (existT _ ....) = S n), since not all applications 82 | * of eq_refl should be lifted that way. So going in this direction is not 83 | * decidable in general. We may be able to implement some heuristics to understand 84 | * when eq_refl actually refers to equalities of projections that include rewrites, 85 | * but this goes against the original contract for when it's OK to call Algebraic. 86 | * So it is probably better to go along a different equivalence. 87 | *) 88 | 89 | Definition consV' (T : Type) (n : nat) (t : T) (v : vector T n) := 90 | Test.consV T n t v. 91 | 92 | Lift vector packed in consV' as conspv'. 93 | Fail Lift vector list in conspv' as cons'. 94 | 95 | (* 96 | * Note that for uncached, this doesn't mean all is lost. 97 | * We can still lift the left projection without issue: 98 | *) 99 | Definition conspv_index T n t v := projT1 (conspv' T n t v). 100 | Lift vector list in conspv_index as cons_index'. 101 | 102 | (* 103 | * Just without more heuristics (which I can implement at some point), it can't 104 | * figure out to lift the equality proof in the second projection: 105 | *) 106 | Definition conspv_value T n t v := projT2 (conspv' T n t v). 107 | Fail Lift vector list in conspv_value as cons_value'. 108 | 109 | (* 110 | * So if we want packed cons over lists, we can get it, just for now we need 111 | * to provide the equality proof still: 112 | *) 113 | Lemma cons_value' T n t pl : 114 | length (cons_index' T n t pl) = S n. 115 | Proof. 116 | simpl. unfold length. rewrite (projT2 pl). reflexivity. 117 | Defined. 118 | (* 119 | * This is exactly what it couldn't lift (eq_refl n) to automatically: 120 | *) 121 | Print cons_value'. 122 | 123 | (* 124 | * With that we glue it together: 125 | *) 126 | Definition consp' T n t pl : {l : list T & length l = S n} := 127 | existT _ (cons_index' T n t pl) (cons_value' T n t pl). 128 | 129 | (* We used a different length proof so these are not refl, 130 | but still work: *) 131 | Lemma consp_consp': 132 | forall T n t pl, 133 | consp T n t pl = consp' T n t pl. 134 | Proof. 135 | intros. unfold consp, consp'. unfold cons_index', cons_value', packed_list_rect. 136 | unfold orn_list_vector_rect. simpl. unfold packed_rect. simpl. 137 | unfold eq_ind_r. f_equal. unfold id. simpl. 138 | induction pl. rewrite <- p. auto. 139 | Qed. 140 | 141 | (* 142 | * With caching, we don't have to worry about the eq_refl proof, since it remembers 143 | * what that proof corresponded to: 144 | *) 145 | Lift vector packed in consV as conspv''. 146 | Lift vector list in conspv'' as cons''. 147 | 148 | (* --- Once the above works in both directions, I'll add the rest of the tests --- *) 149 | 150 | (* 151 | * For now, a few more basic tests (note below doesn't work with consV instead of Test.consV): 152 | *) 153 | 154 | Definition packed_cons (T : Type) (n : nat) (v : vector T n) (t : T) := 155 | existT _ (S n) (Test.consV T n t v). 156 | Lift vector packed in packed_cons as packed_cons'. 157 | 158 | Definition packed_nil (T : Type) := existT _ 0 (Test.nilV T). 159 | Lift vector packed in packed_nil as packed_nil'. 160 | 161 | Print packed_nil'. 162 | Print packed_cons'. 163 | -------------------------------------------------------------------------------- /plugin/coq/examples/Intro.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Section 1 Example, using DEVOID 3 | *) 4 | 5 | Require Import Vector. 6 | Require Import List. 7 | Require Import Ornamental.Ornaments. 8 | 9 | (* syntax to match paper *) 10 | Notation vector := Vector.t. 11 | 12 | (* 13 | * map_length from the list standard library 14 | *) 15 | Check map_length. 16 | 17 | (* 18 | * Coq's vector map. 19 | *) 20 | Check Vector.map. 21 | 22 | (* --- Bonus material --- *) 23 | 24 | (* 25 | * We can get Vector.map from List.map. 26 | *) 27 | 28 | Preprocess List.map as list_map'. 29 | Find ornament list vector as ltv. 30 | Lift list vector in list_map' as map_p. 31 | Unpack map_p as map_u. 32 | 33 | (* User-friendly version *) 34 | Program Definition map {T1} {T2} (f : T1 -> T2) {n : nat} (v : vector T1 n) : vector T2 n := 35 | map_u T1 T2 f n v. 36 | Next Obligation. 37 | induction v. 38 | - auto. 39 | - simpl. f_equal. auto. 40 | Defined. 41 | 42 | (* We can show it's the same as Coq's map *) 43 | Lemma map_correct : 44 | forall {T1} {T2} (f : T1 -> T2) {n : nat} (v : vector T1 n), 45 | map f v = Vector.map f v. 46 | Proof. 47 | intros. induction v. 48 | - auto. 49 | - simpl. rewrite <- IHv. unfold map. simpl. 50 | destruct (map_obligation_1 T1 T2 f n v). auto. 51 | Qed. 52 | -------------------------------------------------------------------------------- /plugin/coq/examples/Lift.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Walkthrough of lifting for Section 4 3 | *) 4 | 5 | Add LoadPath "coq/examples". 6 | Require Import Vector. 7 | Require Import List. 8 | Require Import Ornamental.Ornaments. 9 | Require Import Search. (* our ornament *) 10 | 11 | (* 12 | * Our arguments to cons are swapped from Coq's in the paper 13 | *) 14 | Definition vect_rect {T : Type} p f_nil f_cons (n : nat) (v : vector T n) := 15 | Vector.t_rect T p 16 | f_nil 17 | (fun (t : T) (n : nat) (v : vector T n) (IH : p n v) => 18 | f_cons n t v IH) 19 | n 20 | v. 21 | 22 | (* 23 | * Note we have this nice equality between eliminators: 24 | *) 25 | Example lift_elim_correct: 26 | forall {T : Type} p_A f_nil f_cons n (v : vector T n), 27 | list_rect p_A 28 | f_nil 29 | f_cons 30 | (forget (existT _ n v)) 31 | = 32 | vect_rect (fun n v => p_A (forget (existT _ n v))) 33 | f_nil 34 | (fun n t v IH => f_cons t (forget (existT _ n v)) IH) 35 | n 36 | v. 37 | Proof. 38 | induction v. 39 | - reflexivity. 40 | - simpl. f_equal. apply IHv. 41 | Qed. 42 | 43 | (* 44 | * So, what does it look like when we lift an eliminator 45 | * application? 46 | *) 47 | Definition proof T p_A f_nil f_cons (l : list T) := 48 | list_rect p_A 49 | f_nil 50 | f_cons 51 | l. 52 | 53 | Lift list vector in proof as proofV_p. 54 | Print proofV_p. 55 | 56 | (* --- Lifting constructors --- *) 57 | 58 | (* 59 | * In the base case, we just normalize: 60 | *) 61 | Lift list vector in @nil as nilV_p. 62 | Print nilV_p. 63 | 64 | (* 65 | * As mentioned in the implementation section, 66 | * refolding happens here to deal with constants. 67 | * But the equalities should be clear that way: 68 | *) 69 | Lift list vector in @cons as consV_p. 70 | Print consV_p. 71 | 72 | 73 | (* --- Lifting --- *) 74 | 75 | (* 76 | * Let's lift a few simple list functions, now 77 | *) 78 | 79 | Preprocess hd as hd'. 80 | Lift list vector in hd' as hdV_p. 81 | Print hdV_p. 82 | 83 | Preprocess tl as tl'. 84 | Lift list vector in tl' as tlV_p. 85 | Print tlV_p. 86 | 87 | Preprocess remove as remove'. 88 | Lift list vector in remove' as removeV_p. 89 | Print removeV_p. 90 | -------------------------------------------------------------------------------- /plugin/coq/examples/LiftSpec.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Section 3.2 Examples 3 | *) 4 | 5 | Add LoadPath "coq/examples". 6 | Require Import Vector. 7 | Require Import List. 8 | Require Import Ornamental.Ornaments. 9 | Require Import Search. (* <-- includes our ornament *) 10 | Require Import Example. (* <-- includes our functions *) 11 | 12 | (* syntax to match paper *) 13 | Notation vector := Vector.t. 14 | Notation consV n t v := (Vector.cons _ t n v). 15 | Notation nilV := Vector.nil. 16 | Notation promote := ltv. 17 | Notation zip := hs_to_coq.zip. 18 | Notation zip_with_is_zip := hs_to_coq.zip_with_is_zip. 19 | Arguments zip {_} {_} _ _. 20 | Arguments zipV_p {_} {_} _ _. 21 | Arguments promote {_} _. 22 | 23 | (* --- Types go to types --- *) 24 | 25 | Lift list vector in list as vector_p. 26 | Print vector_p. 27 | 28 | (* --- Terms go to terms --- *) 29 | 30 | Lift list vector in (cons 5 nil) as v_p. 31 | Print v_p. 32 | 33 | (* --- Functions take inputs to inputs, and outputs to outputs --- *) 34 | 35 | (* auxiliary lemma to refold constructors *) 36 | Lemma promote_pres_cons: 37 | forall {T} (t : T) (l : list T), 38 | promote (cons t l) = 39 | existT _ 40 | (S (projT1 (promote l))) 41 | (consV (projT1 (promote l)) t (projT2 (promote l))). 42 | Proof. 43 | auto. 44 | Qed. 45 | 46 | Ltac refold := rewrite promote_pres_cons. 47 | 48 | (* 49 | * With that in mind, the proof is pretty simple: 50 | *) 51 | Example lift_pres_zip: 52 | forall {T1} {T2} (l1 : list T1) (l2 : list T2), 53 | promote (zip l1 l2) = 54 | zipV_p (promote l1) (promote l2). 55 | Proof. 56 | induction l1; auto. refold. 57 | induction l2; auto. simpl. refold. refold. 58 | rewrite (IHl1 l2). 59 | auto. 60 | Qed. 61 | 62 | (* --- Dependent types make this harder to state --- *) 63 | 64 | Check hs_to_coq.zip_with_is_zip. 65 | 66 | (* conclusions are incomparable *) 67 | Fail Example bad_intuition: 68 | forall {A} {B} (l1 : list A) (l2 : list B), 69 | zip_with_is_zip A B l1 l2 = 70 | zip_with_is_zipV_p A B (promote l1) (promote l2). 71 | (* we really need a heterogenous relation *) 72 | -------------------------------------------------------------------------------- /plugin/coq/examples/ListToVect.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Section 5 Preprocess Example 3 | *) 4 | 5 | Require Import Vector. 6 | Require Import List. 7 | Require Import ZArith. 8 | 9 | Require Import Ornamental.Ornaments. 10 | 11 | Notation "( x ; y )" := (existT _ x y) (no associativity). 12 | Notation "p .1" := (projT1 p) (left associativity, at level 8, format "p .1"). 13 | Notation "p .2" := (projT2 p) (left associativity, at level 8, format "p .2"). 14 | Notation "p .&" := (p.1; p.2) (left associativity, at level 6, format "p .&"). 15 | 16 | Notation vector := Vector.t. 17 | Notation vnil := Vector.nil. 18 | Notation vcons := Vector.cons. 19 | 20 | (* --- Preprocess --- *) 21 | 22 | Preprocess Module List as List' { opaque (* ignore these: *) 23 | RelationClasses 24 | Nat 25 | Coq.Init.Nat 26 | }. 27 | 28 | (* --- Search & Lift --- *) 29 | 30 | (* We use automatic search here rather than calling Find Ornament ourselves. *) 31 | 32 | Definition list_elim A P : P nil -> (forall x xs, P xs -> P (cons x xs)) -> forall xs, P xs := 33 | fun H__nil H__cons xs => @list_rect A P H__nil H__cons xs. 34 | 35 | Lift list vector in list_elim as vect_elim. 36 | 37 | Check (vect_elim : 38 | forall (A : Type) (P : {n : nat & vector A n} -> Type), 39 | P (0; vnil A) -> 40 | (forall (x : A) (xs : {n : nat & vector A n}), 41 | P xs.& -> P (S xs.1; vcons A x xs.1 xs.2)) -> 42 | forall (xs : {n : nat & vector A n}), 43 | P xs.&). 44 | 45 | Lift Module list vector in List' as Vector' { opaque (* ignore these, just for speed *) 46 | RelationClasses.Equivalence_Reflexive 47 | RelationClasses.reflexivity 48 | Nat.add 49 | Nat.sub 50 | Nat.lt_eq_cases 51 | Nat.compare_refl 52 | Nat.lt_irrefl 53 | Nat.le_refl 54 | Nat.bi_induction 55 | Nat.central_induction 56 | }. 57 | 58 | (* 59 | * There are still two proofs (`partition_length` and `elements_in_partition`) 60 | * that fail to lift above, due to implementation bugs. 61 | * See: https://github.com/uwplse/ornamental-search/issues/32 62 | * 63 | * The effort here is fully automatic, whereas the old tactics don't work for 64 | * the repaired proofs here, so there are obvious development time savings. 65 | *) 66 | -------------------------------------------------------------------------------- /plugin/coq/examples/ListToVectCustom.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Custom equivalences for ListToVect 3 | *) 4 | 5 | Require Import Vector. 6 | Require Import List. 7 | Require Import ZArith. 8 | 9 | Require Import Ornamental.Ornaments. 10 | 11 | Set DEVOID search prove equivalence. 12 | 13 | Notation vector := Vector.t. 14 | Notation vnil := Vector.nil. 15 | Notation vcons := Vector.cons. 16 | 17 | (* --- Preprocess --- *) 18 | 19 | Preprocess Module List as List' { opaque (* ignore these: *) 20 | RelationClasses 21 | Nat 22 | Coq.Init.Nat 23 | }. 24 | 25 | (* --- Length function --- *) 26 | 27 | (* 28 | * We can set our indexer to instead be the list length function if we'd like. 29 | * First we find the original ornament: 30 | *) 31 | Find ornament list vector. 32 | 33 | (* 34 | * Then we modify it. 35 | * 36 | * For now, the algorithm makes some annoying assumptions about the form that the 37 | * equivalence takes. In particular, if we apply (projT2 (list_to_t T l)), it's going 38 | * to try to recursively lift the argument l to (list_to_t T l), which is annoying. 39 | * Similarly, it sometimes unfolds things to match over lists and doesn't figure out 40 | * how to refold it when our equivalence is complex, which is technically correct, 41 | * except that later on recursive attempts match over lists and call pattern 42 | * matching rules which are unsupported, rather than using eliminators. 43 | * We should fix these bugs. They do not have to do with the theory, just the 44 | * implementation, in particular because of constants and efficiency. 45 | * 46 | * In the meantime, we print and substitute so these problems don't show up. 47 | *) 48 | 49 | (* Print list_to_t. *) (* <--- Uncomment to see the old function *) 50 | 51 | Definition ltv := 52 | fun (A : Type) (l : list A) => 53 | existT (fun H : nat => vector A H) (length l) 54 | (list_rect (fun l0 : list A => vector A (length l0)) 55 | (vnil A) 56 | (fun (a : A) (l0 : list A) 57 | (H : (fun (_ : nat) (l1 : list A) => vector A (length l1)) 58 | (length l0) l0) => vcons A a (length l0) H) l). 59 | 60 | (* 61 | * The correctness condition is that these also form an equivalence with the same 62 | * coherence properties. We don't need to prove this, however. We can just tell 63 | * DEVOID to use our equivalence. (Use at your own risk! If you pick something that isn't an equivalence, 64 | * lifting will fail with confusing type errors.) 65 | *) 66 | Save ornament list vector { promote = ltv }. 67 | 68 | (* 69 | * The cute thing is that we can now lift all of these using the length function: 70 | *) 71 | Lift Module list vector in List' as Vector { opaque (* ignore these, just for speed *) 72 | RelationClasses.Equivalence_Reflexive 73 | RelationClasses.reflexivity 74 | Nat.add 75 | Nat.sub 76 | Nat.lt_eq_cases 77 | Nat.compare_refl 78 | Nat.lt_irrefl 79 | Nat.le_refl 80 | Nat.bi_induction 81 | Nat.central_induction 82 | }. 83 | 84 | (* 85 | * One nice thing about this is that we can lift these directly: 86 | *) 87 | Definition packed_list T n := { l : list T & length l = n }. 88 | Lift list vector in packed_list as packed_vector_proof. 89 | 90 | (* 91 | * This gives us something still equivalent to a vector, and the proof 92 | * is much easier. This is the next equivalence we should compose with. 93 | * And when we see a vector, we should use this one directly. It should 94 | * always follow from the algebraic ornament. 95 | *) 96 | Program Definition unpack T n (s : packed_vector_proof T n) : vector T n. 97 | Proof. 98 | induction s. induction x. rewrite <- p. apply p0. 99 | Defined. 100 | 101 | Program Definition pack T n (v : vector T n) : packed_vector_proof T n. 102 | Proof. 103 | exists (existT _ n v). reflexivity. 104 | Defined. 105 | 106 | Lemma pack_section: 107 | forall T n s, pack T n (unpack T n s) = s. 108 | Proof. 109 | intros T n s. induction s. induction x. rewrite <- p. simpl. reflexivity. 110 | Defined. 111 | 112 | Lemma pack_retraction: 113 | forall T n v, unpack T n (pack T n v) = v. 114 | Proof. 115 | intros T n v. reflexivity. 116 | Defined. 117 | 118 | (* 119 | * In theory, we could define a nicer eliminator using packed_list, then. 120 | * And then do another eliminator transformation. 121 | * In practice, I haven't really found this to be any easier, but I'll keep trying. 122 | *) 123 | 124 | -------------------------------------------------------------------------------- /plugin/coq/examples/Projections.v: -------------------------------------------------------------------------------- 1 | (* 2 | * The troubles of non-primitive projections. 3 | *) 4 | Require Import Example. 5 | 6 | (* 7 | * This doesn't work: 8 | *) 9 | Theorem convert: 10 | forall (T : Type) (v : sigT (vector T)), 11 | v = existT _ (projT1 v) (projT2 v). 12 | Proof. 13 | Fail reflexivity. 14 | Abort. 15 | 16 | (* 17 | * So in general, if you want to preserve definitional equalities, 18 | * you need to expand every v to existT _ (projT1 v) (projT2 v). 19 | *) 20 | 21 | (* 22 | * We can optimize some terms, though, and avoid packing in some cases, since: 23 | *) 24 | Theorem convert: 25 | forall (T : Type) (n : nat) (v : vector T n), 26 | existT _ v n = existT _ (projT1 (existT _ v n)) (projT2 (existT _ v n)). 27 | Proof. 28 | reflexivity. 29 | Qed. 30 | -------------------------------------------------------------------------------- /plugin/coq/examples/Search.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Walkthrough of search for Section 4 3 | *) 4 | 5 | Add LoadPath "coq/examples". 6 | Require Import Vector. 7 | Require Import List. 8 | Require Import Ornamental.Ornaments. 9 | 10 | (* syntax to match paper *) 11 | Notation vector := Vector.t. 12 | Notation consV n t v := (Vector.cons _ t n v). 13 | Notation nilV := Vector.nil. 14 | 15 | (* --- Running search --- *) 16 | 17 | Set DEVOID search prove coherence. 18 | Set DEVOID search prove equivalence. 19 | 20 | Find ornament list vector as ltv. 21 | 22 | (* --- Indexer ---*) 23 | 24 | (* 25 | * Our generated indexer is ltv_index: 26 | *) 27 | Print ltv_index. 28 | 29 | (* 30 | * Let's call this the indexer: 31 | *) 32 | Notation indexer l := (ltv_index _ l). 33 | 34 | (* 35 | * Note that this computes the length: 36 | *) 37 | Example indexer_is_length: 38 | forall {T : Type} (l : list T), 39 | indexer l = length l. 40 | Proof. 41 | reflexivity. 42 | Qed. 43 | 44 | (* --- Promote --- *) 45 | 46 | (* 47 | * Promote is ltv: 48 | *) 49 | Print ltv. 50 | 51 | (* 52 | * Let's call this promote: 53 | *) 54 | Notation promote l := (ltv _ l). 55 | 56 | (* --- Forget --- *) 57 | 58 | (* 59 | * Forget is ltv_inv: 60 | *) 61 | Print ltv_inv. 62 | 63 | (* 64 | * Let's call this forget 65 | *) 66 | Notation forget l := (ltv_inv _ l). 67 | 68 | (* --- Correctness --- *) 69 | 70 | (* 71 | * Since we set the "prove coherence" and "prove equivalence" options, 72 | * DEVOID generated coherence, section, and retraction proofs. Here I 73 | * simply restate them and show that the generated terms are correct. 74 | * These automatically generated proofs show that the components DEVOID 75 | * found form the ornamental promotion isomorphism between lists and vectors. 76 | * 77 | * Coherence follows by construction, while section and retraction each 78 | * follow by induction, where each case is a fold over rewrites by each 79 | * recursive argument, ending with reflexivity. 80 | *) 81 | 82 | Theorem coherence: 83 | forall {T : Type} (l : list T), 84 | indexer l = projT1 (promote l). 85 | Proof. 86 | exact ltv_coh. 87 | Qed. 88 | 89 | Theorem section: 90 | forall {T : Type} (l : list T), 91 | forget (promote l) = l. 92 | Proof. 93 | exact ltv_section. 94 | Qed. 95 | 96 | Theorem retraction: 97 | forall {T : Type} (v : sigT (fun n => vector T n)), 98 | promote (forget v) = v. 99 | Proof. 100 | exact ltv_retraction. 101 | Qed. 102 | 103 | Theorem adjunction: 104 | forall {T : Type} (l : list T), 105 | ltv_retraction_adjoint T (ltv T l) = f_equal (ltv T) (ltv_section T l). 106 | Proof. 107 | exact ltv_adjunction. 108 | Qed. 109 | -------------------------------------------------------------------------------- /plugin/coq/handshake.v: -------------------------------------------------------------------------------- 1 | From Ornamental Require Import Ornaments. 2 | 3 | (* 4 | * This is a test from a user that ensures record projections lift correctly. 5 | *) 6 | 7 | Set DEVOID search prove equivalence. 8 | Set DEVOID lift type. 9 | 10 | Set Preprocess default opaque. 11 | 12 | Module Handshake. 13 | 14 | Definition handshake : Type 15 | := (bool * bool). 16 | 17 | End Handshake. 18 | 19 | Module HandshakePP. 20 | 21 | Preprocess Module Handshake as HandshakePP. 22 | 23 | End HandshakePP. 24 | 25 | Import HandshakePP. 26 | 27 | Module HandshakeRecord. 28 | 29 | Record Handshake := 30 | MkHandshake 31 | { 32 | handshakeType : bool; 33 | messageNumber : bool; 34 | }. 35 | 36 | Scheme Induction for Handshake Sort Prop. 37 | Scheme Induction for Handshake Sort Type. 38 | Scheme Induction for Handshake Sort Set. 39 | 40 | Definition get_handshake_type (h : HandshakePP.handshake) : bool := 41 | fst h. 42 | 43 | Definition get_message_number (h : HandshakePP.handshake) : bool := 44 | snd h. 45 | 46 | End HandshakeRecord. 47 | 48 | Preprocess Module HandshakeRecord as HandshakeRecordPP. 49 | 50 | Module HandshakeLift. 51 | 52 | Lift HandshakePP.handshake 53 | HandshakeRecordPP.Handshake 54 | in HandshakeRecordPP.get_handshake_type 55 | as getHandshakeType. 56 | 57 | Lift HandshakePP.handshake 58 | HandshakeRecordPP.Handshake 59 | in HandshakeRecordPP.get_message_number 60 | as getMessageNumber. 61 | 62 | End HandshakeLift. 63 | 64 | Module Connection. 65 | 66 | Definition connection : Type 67 | := (bool (* client_auth_flag *) 68 | * (bool (* corked *) 69 | * (bool (* corked_io *) 70 | * (Handshake.handshake 71 | * (bool (* is_caching_enabled *) 72 | * (bool (* key_exchange_eph *) 73 | * (bool (* mode *) 74 | * (bool (* resume_from_cache *) 75 | * nat (* server_can_send_ocsp *) 76 | ) 77 | ) 78 | ) 79 | ) 80 | ) 81 | ) 82 | ) 83 | ) 84 | . 85 | 86 | End Connection. 87 | 88 | Module ConnectionPP. 89 | 90 | Preprocess Module Connection as ConnectionPP. 91 | 92 | End ConnectionPP. 93 | 94 | Import ConnectionPP. 95 | 96 | Module ConnectionRecord. 97 | 98 | Record Connection := 99 | MkConnection 100 | { 101 | clientAuthFlag : bool; 102 | corked : bool; 103 | corkedIO : bool; 104 | handshake : HandshakeRecord.Handshake; 105 | isCachingEnabled : bool; 106 | keyExchangeEPH : bool; 107 | mode : bool; 108 | resumeFromCache : bool; 109 | serverCanSendOCSP : nat; 110 | }. 111 | 112 | Scheme Induction for Connection Sort Prop. 113 | Scheme Induction for Connection Sort Type. 114 | Scheme Induction for Connection Sort Set. 115 | 116 | Definition get_client_auth_flag (c : Connection.connection) : bool := 117 | fst c. 118 | 119 | Definition get_corked (c : Connection.connection) : bool := 120 | fst (snd c). 121 | 122 | Definition get_corked_IO (c : Connection.connection) : bool := 123 | fst (snd (snd c)). 124 | 125 | Definition get_handshake (c : Connection.connection) : Handshake.handshake := 126 | fst (snd (snd (snd c))). 127 | 128 | Definition get_is_caching_enabled (c : Connection.connection) : bool := 129 | fst (snd (snd (snd (snd c)))). 130 | 131 | Definition get_key_exchange_EPH (c : Connection.connection) : bool := 132 | fst (snd (snd (snd (snd (snd c))))). 133 | 134 | Definition get_mode (c : Connection.connection) : bool := 135 | fst (snd (snd (snd (snd (snd (snd c)))))). 136 | 137 | Definition get_resume_from_cache (c : Connection.connection) : bool := 138 | fst (snd (snd (snd (snd (snd (snd (snd c))))))). 139 | 140 | Definition get_server_can_send_ocsp (c : Connection.connection) : nat := 141 | snd (snd (snd (snd (snd (snd (snd (snd c))))))). 142 | 143 | End ConnectionRecord. 144 | 145 | Preprocess Module ConnectionRecord as ConnectionRecordPP0. 146 | 147 | Print ConnectionRecordPP0. 148 | 149 | Lift Module HandshakePP.handshake 150 | HandshakeRecordPP.Handshake 151 | in ConnectionRecordPP0 152 | as ConnectionRecordPP1. 153 | 154 | (* We need to be able to talk about the type that is just like ConnectionPP.connection, but with 155 | HandshakePP.handshake replaced with HandshakeRecordPP.Handshake. 156 | *) 157 | Lift Handshake.handshake 158 | HandshakeRecordPP.Handshake 159 | in ConnectionPP.connection 160 | as ConnectionPPHandshakeRecordPP. (* used to be connectionPP *) 161 | 162 | Check (ConnectionRecordPP1.get_corked : ConnectionPPHandshakeRecordPP -> bool). 163 | 164 | Lift HandshakeRecord.Handshake 165 | HandshakeRecordPP.Handshake 166 | in ConnectionRecordPP1.Connection 167 | as connectionRecordPP. 168 | 169 | Print ConnectionRecordPP1.Connection. 170 | 171 | Print ConnectionRecordPP1. 172 | 173 | Print ConnectionPPHandshakeRecordPP. 174 | Print connectionRecordPP. 175 | 176 | Print ConnectionRecordPP1. 177 | Find ornament ConnectionPPHandshakeRecordPP connectionRecordPP. 178 | 179 | (* Problem 1: all liftings appear to fail here *) 180 | Lift Module 181 | ConnectionPPHandshakeRecordPP (* used to be connectionPP *) 182 | connectionRecordPP (* used to be connectionRecordPP *) 183 | in ConnectionRecordPP1 184 | as ConnectionRecordPP. 185 | 186 | 187 | (* Trying one field manually: *) 188 | Lift HandshakePP.handshake 189 | HandshakeRecordPP.Handshake 190 | in ConnectionRecordPP0.get_corked 191 | as getCorked0. 192 | 193 | Check (getCorked0 : ConnectionPPHandshakeRecordPP -> bool). 194 | 195 | (* indeed it ought to be the same: *) 196 | Lemma check1 : getCorked0 = ConnectionRecordPP1.get_corked. 197 | Proof. 198 | reflexivity. 199 | Qed. 200 | 201 | (* 202 | this fails here, but in my original file, it succeeds, and I'm having trouble 203 | figuring out where I must have made a mistake... 204 | *) 205 | Lift ConnectionPPHandshakeRecordPP 206 | connectionRecordPP 207 | in getCorked0 208 | as getCorked. 209 | -------------------------------------------------------------------------------- /plugin/coq/minimal_records.v: -------------------------------------------------------------------------------- 1 | Require Import Ornamental.Ornaments. 2 | 3 | Set DEVOID search prove equivalence. (* <-- Correctness proofs for search *) 4 | Set DEVOID lift type. (* <-- Prettier types than the ones Coq infers *) 5 | Set Nonrecursive Elimination Schemes. (* <--- Preprocess needs induction principles for records *) 6 | 7 | (* 8 | * This is an example for lifting between nested tuples and records. 9 | *) 10 | 11 | (* 12 | * In this example, we have some generated code that uses nested tuples: 13 | *) 14 | Module Generated. 15 | 16 | Definition input := (prod bool (prod nat bool)). 17 | 18 | Definition output := (prod nat bool). 19 | 20 | Definition firstBool (r : (prod bool (prod nat bool))) : bool := 21 | (fst r). 22 | 23 | Definition numberI (r : (prod bool (prod nat bool))) : nat := 24 | (fst (snd r)). 25 | 26 | Definition secondBool (r : (prod bool (prod nat bool))) : bool := 27 | (snd (snd r)). 28 | 29 | Definition numberO (r : (prod nat bool)) : nat := 30 | (fst r). 31 | 32 | Definition andBools (r : (prod nat bool)) : bool := 33 | (snd r). 34 | 35 | Definition op (r : (prod bool (prod nat bool))) : (prod nat bool) := 36 | (pair 37 | (numberI r) 38 | (andb 39 | (firstBool r) 40 | (secondBool r) 41 | ) 42 | ). 43 | 44 | End Generated. 45 | 46 | (* 47 | * We want to write proofs over the record versions of these, which 48 | * are easier to read about. We start by defining the record versions 49 | * of input and output ourselves: 50 | *) 51 | Module Handwritten. 52 | 53 | Record input := MkInput 54 | { 55 | firstBool : bool; 56 | numberI : nat; 57 | secondBool : bool; 58 | }. 59 | 60 | Record output := MkOutput 61 | { 62 | numberO : nat; 63 | andBools : bool; 64 | }. 65 | 66 | End Handwritten. 67 | 68 | (* 69 | * Now we Preprocess in both directions, since we'll lift in 70 | * both directions. 71 | *) 72 | Preprocess Module Generated as Generated'. 73 | Preprocess Module Handwritten as Handwritten'. 74 | 75 | (* 76 | * The easiest way to lift these is to just lift the module twice, first for 77 | * input (bigger type) then for output (smaller type): 78 | *) 79 | Lift Module Generated'.input Handwritten'.input in Generated' as Temp1. 80 | Lift Module Generated'.output Handwritten'.output in Temp1 as Handwritten''. 81 | 82 | (* 83 | * If you lift in the opposite order, for op, you get something well-typed but with 84 | * a type you don't even want. So for now when one type definition you lift along 85 | * is a subterm of another type definition you lift along, you will need to start 86 | * with the bigger one and then tell DEVOID to treat the lifted projections as opaque. 87 | * Really interesting WIP on handling this better without so much work for the user. 88 | * 89 | * See: https://taliasplse.wordpress.com/2020/02/02/automating-transport-with-univalent-e-graphs/ 90 | *) 91 | 92 | (* 93 | * OK, now that we're in the handwritten world, we can write our proofs over 94 | * these nicer types: 95 | *) 96 | Module HandwrittenProofs. 97 | 98 | Theorem and_spec_true_true 99 | (r : Handwritten'.input) 100 | (F : Handwritten''.firstBool r = true) 101 | (S : Handwritten''.secondBool r = true) 102 | : Handwritten''.andBools (Handwritten''.op r) = true. 103 | Proof. 104 | destruct r as [f n s]. 105 | unfold Handwritten''.op. 106 | simpl in *. 107 | apply andb_true_intro. 108 | intuition. 109 | Qed. 110 | 111 | End HandwrittenProofs. 112 | 113 | (* 114 | * Let's Preprocess this proof for lifting: 115 | *) 116 | Preprocess Module HandwrittenProofs as HandwrittenProofs'. 117 | 118 | (* 119 | * Then lift it back to our nested pair types. 120 | * I think this is order sensitive if we want something that looks nice, since we 121 | * lifted op in one order so we only have nice cached intermediate constants if we go 122 | * in the opposite order. But it will work regardless of which direction you do. 123 | *) 124 | Lift Handwritten'.output Generated'.output in HandwrittenProofs'.and_spec_true_true as and_spec_true_true_1. 125 | Repair Handwritten'.input Generated'.input in and_spec_true_true_1 as and_spec_true_true'. 126 | 127 | (* 128 | * Tweaking those tactics, we can get back the original proof even forgetting about 129 | * Preprocessing. 130 | *) 131 | Theorem and_spec_true_true 132 | (r : Generated.input) 133 | (F : Generated.firstBool r = true) 134 | (S : Generated.secondBool r = true) 135 | : Generated.andBools (Generated.op r) = true. 136 | Proof. 137 | induction r. 138 | apply (andb_true_intro (conj F S)). 139 | Qed. 140 | 141 | (* We are done! *) 142 | 143 | (* 144 | * This is fully automatic, save for tweaking the tactics. 145 | * What do we get if we try to do this manually? 146 | * Let's start with the old proof. 147 | * The time is 10:29, end time is 10:31. So comparable effort, 148 | * since we need to tweak the tactics a bit, and the proof is really easy, 149 | * but that's just for the proof---we'd also need to port all of the functions, 150 | * like we did above. That took some time, but here we got it for free. 151 | * So we get a slight savings in development time overall. 152 | *) 153 | Theorem and_spec_true_true_manual 154 | (r : Generated.input) 155 | (F : Generated.firstBool r = true) 156 | (S : Generated.secondBool r = true) 157 | : Generated.andBools (Generated.op r) = true. 158 | Proof. 159 | destruct r as [n b]. 160 | unfold Generated.op. 161 | simpl in *. 162 | apply andb_true_intro. 163 | intuition. 164 | Qed. 165 | (* 166 | * All we change is the first line to get rid of the warning. 167 | *) 168 | -------------------------------------------------------------------------------- /plugin/coq/playground/Anders.v: -------------------------------------------------------------------------------- 1 | Require Import List. 2 | 3 | Import ListNotations. 4 | 5 | Require Import Ornamental.Ornaments. 6 | Set DEVOID search prove equivalence. 7 | Set DEVOID lift type. 8 | 9 | (* Preprocess for lifting: *) 10 | Preprocess Module List as List_pre { opaque (* ignore these nested modules: *) 11 | RelationClasses 12 | Nat Coq.Init.Nat 13 | Coq.Init.Logic Coq.Init.Peano 14 | Coq.Init.Datatypes.list_ind Coq.Init.Datatypes.list_rect Coq.Init.Datatypes.list_rec 15 | Coq.Init.Datatypes.nat_ind Coq.Init.Datatypes.nat_rect Coq.Init.Datatypes.nat_rec 16 | eq_ind eq_ind_r eq_rec eq_rec_r eq_rect eq_rect_r 17 | }. 18 | 19 | Inductive revList (T : Type) : Type := 20 | | nil : revList T 21 | | cons : T -> revList T -> revList T. 22 | 23 | Print List_pre.rev. 24 | Print List_pre.Coq_Init_Datatypes_app. 25 | 26 | Definition f_helper (T : Type) (l : revList T) := 27 | revList_rect 28 | T 29 | (fun _ : revList T => revList T -> revList T) 30 | (fun m : revList T => m) 31 | (fun (t : T) _ (app : revList T -> revList T) (m : revList T) => 32 | cons T t (app m)) 33 | l. 34 | 35 | Definition f (T : Type) (l : list T) : revList T := 36 | @list_rect 37 | T 38 | (fun _ : list T => revList T) 39 | (nil T) 40 | (fun (t : T) _ (rev : revList T) => 41 | f_helper T rev (cons T t (nil T))) 42 | l. 43 | 44 | Eval compute in (f _ (5 :: [7])). 45 | 46 | (* 47 | * What is the corresponding eliminator? 48 | *) 49 | 50 | 51 | -------------------------------------------------------------------------------- /plugin/coq/playground/constr_extension.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq/playground". 2 | Require Import List. 3 | Require Import Ornamental.Ornaments. 4 | 5 | Set DEVOID search prove equivalence. 6 | Set DEVOID lift type. 7 | 8 | (* 9 | * Attempts at figuring equivalences that correspond to constructor extension, 10 | * and the corresponding eliminator transformation, so we can make a good 11 | * interface for asking the user for exactly the new information that is needed, 12 | * and inferring it when possible. 13 | * 14 | * NOTE: Everything in this file is from February (you can check the history), 15 | * I just accidentally added something irrelevant here and then moved it recently. 16 | *) 17 | 18 | (* --- No new information --- *) 19 | 20 | Module NoNewInformation. 21 | 22 | Inductive list_ext (A : Type) : Type := 23 | | nil_ext : list_ext A 24 | | cons_ext : A -> list_ext A -> list_ext A 25 | | nil_ext2 : list_ext A. 26 | 27 | (* 28 | * This version gets you from proofs about list to proofs about list_ext, but 29 | * just ignores the nil_ext2 case: 30 | *) 31 | 32 | Program Definition list_ext_inv (A : Type) (l : list_ext A) : Prop. 33 | Proof. 34 | induction l. 35 | - apply True. 36 | - apply IHl. 37 | - apply False. 38 | Defined. 39 | 40 | Program Definition list_list_ext : 41 | forall (A : Type), list A -> sigT (fun (l : list_ext A) => list_ext_inv A l). 42 | Proof. 43 | intros A l. induction l. 44 | - exists (nil_ext A). simpl. auto. 45 | - exists (cons_ext A a (projT1 IHl)). simpl. 46 | destruct IHl. simpl. auto. 47 | Defined. 48 | 49 | Program Definition list_ext_list : 50 | forall (A : Type), sigT (fun (l : list_ext A) => list_ext_inv A l) -> list A. 51 | Proof. 52 | intros A lp. induction lp. induction x. 53 | - apply nil. 54 | - apply cons. 55 | + apply a. 56 | + apply IHx. simpl in p. apply p. 57 | - inversion p. 58 | Defined. 59 | 60 | Lemma list_list_ext_cons: 61 | forall (A : Type) (a : A) (l : list A), 62 | list_list_ext A (a :: l) = 63 | existT (fun (l : list_ext A) => list_ext_inv A l) (cons_ext A a (projT1 (list_list_ext A l))) (projT2 (list_list_ext A l)). 64 | Proof. 65 | intros A a l. simpl. auto. 66 | Defined. 67 | 68 | Lemma list_ext_list_cons: 69 | forall (A : Type) (a : A) (l : sigT (fun (l : list_ext A) => list_ext_inv A l)), 70 | list_ext_list A (existT (fun l => list_ext_inv A l) (cons_ext A a (projT1 l)) (projT2 l)) = 71 | a :: list_ext_list A (existT (fun l => list_ext_inv A l) (projT1 l) (projT2 l)). 72 | Proof. 73 | intros A a l. simpl. auto. 74 | Defined. 75 | 76 | Lemma list_ext_eta: 77 | forall (A : Type) (l : sigT (fun (l : list_ext A) => list_ext_inv A l)), 78 | existT (fun (l : list_ext A) => list_ext_inv A l) (projT1 l) (projT2 l) = 79 | l. 80 | Proof. 81 | intros. induction l. auto. 82 | Defined. 83 | 84 | Program Definition list_list_ext_section : 85 | forall (A : Type) (l : list A), list_ext_list A (list_list_ext A l) = l. 86 | Proof. 87 | intros A l. induction l. 88 | - reflexivity. 89 | - rewrite list_list_ext_cons. rewrite list_ext_list_cons. rewrite list_ext_eta. 90 | rewrite IHl. auto. 91 | Defined. 92 | 93 | Program Definition list_list_ext_retraction: 94 | forall (A : Type) (pl : sigT (fun (l : list_ext A) => list_ext_inv A l)), list_list_ext A (list_ext_list A pl) = pl. 95 | Proof. 96 | intros A l. induction l. induction x. 97 | - simpl. simpl in p. destruct p. auto. 98 | - compute. compute in IHx. rewrite IHx. auto. 99 | - simpl. destruct p. 100 | Defined. 101 | 102 | (* 103 | * This version asks you for the extra information needed to get your list proofs 104 | * to proofs about list_ext (TODO what is this?) 105 | *) 106 | 107 | Inductive list_missing (A : Type) : Type := 108 | | missing_nil2 : list_missing A. 109 | 110 | Definition list_missing_inv (A : Type) (lo : option (list_missing A)) : Type := 111 | match lo with 112 | | Some l => prod (list A) (list_missing A) 113 | | None => list A 114 | end. 115 | 116 | Program Definition list_list_ext' : 117 | forall (A : Type), sigT (fun lo => list_missing_inv A lo) -> list_ext A. 118 | Proof. 119 | intros A s. induction s. induction x. 120 | - induction p. induction a0. 121 | + apply nil_ext2. 122 | + apply cons_ext. 123 | * apply a0. 124 | * apply IHa0. 125 | - induction p. 126 | + apply nil_ext. 127 | + apply cons_ext. 128 | * apply a. 129 | * apply IHp. 130 | Defined. 131 | 132 | Program Definition list_ext_list' : 133 | forall (A : Type), list_ext A -> sigT (fun lo => list_missing_inv A lo). 134 | Proof. 135 | intros A l. induction l. 136 | - exists None. apply nil. 137 | - induction IHl. induction x. 138 | + exists (Some a0). induction p. 139 | simpl. apply pair. apply (cons a a1). apply b. 140 | + exists None. apply (cons a p). 141 | - exists (Some (missing_nil2 A)). simpl. 142 | apply pair. 143 | + apply nil. 144 | + apply (missing_nil2 A). 145 | Defined. 146 | 147 | Program Definition list_list_ext_section' : 148 | forall (A : Type) lo, list_ext_list' A (list_list_ext' A lo) = lo. 149 | Proof. 150 | intros A lo. induction lo. destruct x. 151 | - simpl. induction p. induction a. 152 | + simpl. induction b. induction l. reflexivity. 153 | + compute. compute in IHa. rewrite IHa. auto. 154 | - simpl. induction p. 155 | + simpl. auto. 156 | + compute. compute in IHp. rewrite IHp. auto. 157 | Defined. 158 | 159 | Program Definition list_list_ext_retraction': 160 | forall (A : Type) l, list_list_ext' A (list_ext_list' A l) = l. 161 | Proof. 162 | intros A l. induction l. 163 | - simpl. auto. 164 | - simpl. remember (list_ext_list' A l) as l'. induction l'. simpl. 165 | induction x. 166 | + induction p. simpl. rewrite <- IHl. simpl. auto. 167 | + simpl. rewrite <- IHl. simpl. auto. 168 | - simpl. auto. 169 | Defined. 170 | 171 | End NoNewInformation. 172 | 173 | (* --- No new inductive information --- *) 174 | 175 | (* TODO *) 176 | 177 | (* --- New inductive information --- *) 178 | 179 | (* TODO *) 180 | -------------------------------------------------------------------------------- /plugin/coq/playground/constr_refactor.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq/playground". 2 | Require Import Ornamental.Ornaments. 3 | 4 | Set DEVOID search prove equivalence. 5 | Set DEVOID lift type. 6 | 7 | (* --- 9/17: Playing with a Reviewer A example --- *) 8 | 9 | Inductive I := 10 | | A : I 11 | | B : I. 12 | 13 | Module Old'. 14 | 15 | Definition and (i1 i2 : I) : I := 16 | match i1 with 17 | | A => i2 18 | | B => B 19 | end. 20 | 21 | Definition or (i1 i2 : I) : I := 22 | match i1 with 23 | | A => A 24 | | B => i2 25 | end. 26 | 27 | Definition neg (i : I) : I := 28 | match i with 29 | | A => B 30 | | B => A 31 | end. 32 | 33 | Theorem demorgan_1: 34 | forall (i1 i2 : I), 35 | neg (and i1 i2) = 36 | or (neg i1) (neg i2). 37 | Proof. 38 | intros i1 i2. induction i1; auto. 39 | Defined. 40 | 41 | Theorem demorgan_2: 42 | forall (i1 i2 : I), 43 | neg (or i1 i2) = 44 | and (neg i1) (neg i2). 45 | Proof. 46 | intros i1 i2. induction i1; auto. 47 | Defined. 48 | 49 | End Old'. 50 | 51 | Preprocess Module Old' as Old { opaque I_ind }. 52 | Import Old. 53 | 54 | (* We will change the type to this: *) 55 | Inductive J := 56 | | makeJ : bool -> J. 57 | 58 | (* --- Configuration ---*) 59 | 60 | (* 61 | * This example uses manual configuration. Many of the examples we see later will 62 | * do this part automatically! The exact meaning of this will be explained 63 | * later. But essentially, this tells the tool which constructor maps to true 64 | * and which maps to false: 65 | *) 66 | Definition dep_constr_I_0 : I := A. 67 | Definition dep_constr_I_1 : I := B. 68 | 69 | Definition dep_constr_J_0 : J := makeJ true. 70 | Definition dep_constr_J_1 : J := makeJ false. 71 | 72 | (* 73 | * How to eta-expand I and J (trivial here): 74 | *) 75 | Definition eta_I (i : I) : I := i. 76 | Definition eta_J (j : J) : J := j. 77 | 78 | (* 79 | * How to map between eliminators: 80 | *) 81 | Definition dep_elim_I P f0 f1 i : P (eta_I i) := 82 | I_rect P f0 f1 i. 83 | 84 | Definition dep_elim_J P f0 f1 j : P (eta_J j) := 85 | J_rect P (fun b => bool_rect _ f0 f1 b) j. 86 | 87 | (* 88 | * And how to reduce inductive cases of eliminators, which here is trivial since 89 | * there are no inductive cases of these types: 90 | *) 91 | Definition iota_I_0 (P : I -> Type) (f0 : P A) (f1 : P B) (Q : P A -> Type) (H : Q f0) := 92 | H. 93 | 94 | Definition iota_I_1 (P : I -> Type) (f0 : P A) (f1 : P B) (Q : P B -> Type) (H : Q f1) := 95 | H. 96 | 97 | Definition iota_J_0 (P : J -> Type) (f0 : P (makeJ true)) (f1 : P (makeJ false)) (Q : P (makeJ true) -> Type) (H : Q f0) := 98 | H. 99 | 100 | Definition iota_J_1 (P : J -> Type) (f0 : P (makeJ true)) (f1 : P (makeJ false)) (Q : P (makeJ false) -> Type) (H : Q f1) := 101 | H. 102 | 103 | (* --- Equivalence --- *) 104 | 105 | (* 106 | * Automatic configuration also does this part automatically, 107 | * but here we used manual configuration. 108 | * 109 | * For now, manual configuration doesn't construct the 110 | * equivalence, so you need to construct it yourself. 111 | * A bit silly! Should fix this soon. After all, 112 | * it's a really simple algorithm. Our two functions 113 | * eliminate over one type and construct the other: 114 | *) 115 | Definition f (i : I) : J := 116 | dep_elim_I (fun _ => J) dep_constr_J_0 dep_constr_J_1 i. 117 | 118 | Definition g (j : J) : I := 119 | dep_elim_J (fun _ => I) dep_constr_I_0 dep_constr_I_1 j. 120 | 121 | (* 122 | * And our two proofs eliminate over one type and reduce using the iota reduction rules: 123 | *) 124 | Definition section (i : I) : g (f i) = i := 125 | dep_elim_I 126 | (fun i => g (f i) = i) 127 | (iota_I_0 (fun _ => J) dep_constr_J_0 dep_constr_J_1 (fun j => g j = g dep_constr_J_0) eq_refl) 128 | (iota_I_1 (fun _ => J) dep_constr_J_0 dep_constr_J_1 (fun j => g j = g dep_constr_J_1) eq_refl) 129 | i. 130 | 131 | Definition retraction (j : J) : f (g j) = j := 132 | dep_elim_J 133 | (fun j => f (g j) = j) 134 | (iota_J_0 (fun _ => I) dep_constr_I_0 dep_constr_I_1 (fun i => f i = f dep_constr_I_0) eq_refl) 135 | (iota_J_1 (fun _ => I) dep_constr_I_0 dep_constr_I_1 (fun i => f i = f dep_constr_I_1) eq_refl) 136 | j. 137 | 138 | (* --- Saving the configuration and equivalence --- *) 139 | 140 | (* 141 | * Then we just save that: 142 | *) 143 | Save equivalence I J { promote = f; forget = g }. 144 | 145 | Configure Lift I J { 146 | constrs_a = dep_constr_I_0 dep_constr_I_1; 147 | constrs_b = dep_constr_J_0 dep_constr_J_1; 148 | elim_a = dep_elim_I; 149 | elim_b = dep_elim_J; 150 | eta_a = eta_I; 151 | eta_b = eta_J; 152 | iota_a = iota_I_0 iota_I_1; 153 | iota_b = iota_J_0 iota_J_1 154 | }. 155 | 156 | (* --- Repairing the functions and proofs --- *) 157 | 158 | (* 159 | * Now we repair the module: 160 | *) 161 | Repair Module I J in Old as New { hint "auto" }. 162 | 163 | (* 164 | * Our functions behave the same way, but are defined over J instead of I: 165 | *) 166 | Print New.and. 167 | Lemma and_OK: 168 | forall (j1 j2 : J), 169 | New.and j1 j2 = f (Old.and (g j1) (g j2)). 170 | Proof. 171 | intros. induction j1. induction b; auto. 172 | simpl. rewrite retraction. auto. 173 | Defined. 174 | 175 | Print New.or. 176 | Lemma or_OK: 177 | forall (j1 j2 : J), 178 | New.or j1 j2 = f (Old.or (g j1) (g j2)). 179 | Proof. 180 | intros. induction j1. induction b; auto. 181 | simpl. rewrite retraction. auto. 182 | Defined. 183 | 184 | Print New.neg. 185 | Lemma neg_OK: 186 | forall (j : J), 187 | New.neg j = f (Old.neg (g j)). 188 | Proof. 189 | intros. induction j. induction b; auto. 190 | Defined. 191 | 192 | (* 193 | * And our proofs still hold: 194 | *) 195 | Check New.demorgan_1. 196 | Check New.demorgan_2. 197 | 198 | (* --- Using suggested tactics --- *) 199 | 200 | (* 201 | * Let's use the suggested tactics from Repair (up to renaming): 202 | *) 203 | Theorem demorgan_1: 204 | forall j1 j2 : J, 205 | New.neg (New.and j1 j2) = New.or (New.neg j1) (New.neg j2). 206 | Proof. 207 | intros j1 j2. induction j1 as [b]. 208 | induction b as [ | ]; auto. 209 | Defined. 210 | 211 | Theorem demorgan_2: 212 | forall j1 j2 : J, 213 | New.neg (New.or j1 j2) = New.and (New.neg j1) (New.neg j2). 214 | Proof. 215 | intros j1 j2. induction j1 as [b]. 216 | induction b as [ | ]; auto. 217 | Defined. 218 | 219 | (* --- Manual effort --- *) 220 | 221 | (* 222 | * How hard is this to do manually? 223 | * (Using pattern matching even though the tool uses eliminators.) 224 | * Start time: 18:05 225 | * End time: 18:13 226 | * So we get 8 minutes of savings, but with a small overhead of writing the 227 | * configuration above. 228 | *) 229 | Definition and' (i1 i2 : J) : J := 230 | match i1 with 231 | | makeJ true => i2 232 | | makeJ false => makeJ false 233 | end. 234 | 235 | Definition or' (i1 i2 : J) : J := 236 | match i1 with 237 | | makeJ true => makeJ true 238 | | makeJ false => i2 239 | end. 240 | 241 | Definition neg' (i : J) : J := 242 | match i with 243 | | makeJ true => makeJ false 244 | | makeJ false => makeJ true 245 | end. 246 | 247 | Theorem demorgan_1': 248 | forall (i1 i2 : J), 249 | neg' (and' i1 i2) = 250 | or' (neg' i1) (neg' i2). 251 | Proof. 252 | intros i1 i2. induction i1; auto. 253 | induction b; auto. 254 | Defined. 255 | 256 | Theorem demorgan_2': 257 | forall (i1 i2 : J), 258 | neg' (or' i1 i2) = 259 | and' (neg' i1) (neg' i2). 260 | Proof. 261 | intros i1 i2. induction i1; auto. 262 | induction b; auto. 263 | Defined. 264 | 265 | (* --- Note on opposite direction ---*) 266 | 267 | (* 268 | * In the opposite direction, we can used cached terms, 269 | * but if we want to get around matching problems entirely, 270 | * we can just define a different configuration with the 271 | * natural eliminator for J. 272 | *) -------------------------------------------------------------------------------- /plugin/coq/playground/flip.v: -------------------------------------------------------------------------------- 1 | (* 2 | * Question from Anders Mortberg 3 | *) 4 | Require Import Coq.Program.Tactics. 5 | Require Import Ornamental.Ornaments. 6 | 7 | Set DEVOID lift type. 8 | 9 | Parameter T1 : Type. 10 | Parameter T2 : Type. 11 | Parameter T3 : Type. 12 | 13 | Definition A := T1 -> T2 -> T3. 14 | Definition B := T2 -> T1 -> T3. 15 | 16 | Program Definition f : A -> B. 17 | Proof. 18 | unfold A. unfold B. intros a. 19 | intros t2 t1. apply a; auto. 20 | Defined. 21 | 22 | Program Definition g : B -> A. 23 | Proof. 24 | unfold B. unfold A. intros b. 25 | intros t1 t2. apply b; auto. 26 | Defined. 27 | 28 | Lemma section: 29 | forall (a : A), g (f a) = a. 30 | Proof. 31 | intros a. reflexivity. 32 | Defined. 33 | 34 | Lemma retraction: 35 | forall (b : B), f (g b) = b. 36 | Proof. 37 | intros b. reflexivity. 38 | Defined. 39 | 40 | (* 41 | * Then we get: 42 | *) 43 | Definition dep_constr_A_0 (b : B) : A := g b. 44 | Definition dep_constr_B_0 (b : B) : B := b. 45 | 46 | (* 47 | * Eta is trivial: 48 | *) 49 | Definition eta_A (a : A) := a. 50 | Definition eta_B (b : B) := b. 51 | 52 | (* 53 | * This gives us dep_elim: 54 | *) 55 | Program Definition dep_elim_A (P : A -> Type) (f0 : forall (b : B), P (dep_constr_A_0 b)) (a : A) : P (eta_A a). 56 | Proof. 57 | apply f0. 58 | Defined. 59 | 60 | Program Definition dep_elim_B (P : B -> Type) (f0 : forall (b : B), P (dep_constr_B_0 b)) (b : B) : P (eta_B b). 61 | Proof. 62 | apply f0. 63 | Defined. 64 | 65 | (* 66 | * No inductive cases, so trivial iota: 67 | *) 68 | Definition iota_A_0 (P : A -> Type) (f0 : forall (b : B), P (dep_constr_A_0 b)) (b : B) (Q : P (dep_constr_A_0 b) -> Type) (H : Q (f0 b)) := 69 | H. 70 | 71 | Definition iota_B_0 (P : B -> Type) (f0 : forall (b : B), P (dep_constr_B_0 b)) (b : B) (Q : P (dep_constr_B_0 b) -> Type) (H : Q (f0 b)) := 72 | H. 73 | 74 | (* 75 | * Then we just save that: 76 | *) 77 | Save equivalence A B { promote = f; forget = g }. 78 | Configure Lift A B { 79 | constrs_a = dep_constr_A_0; 80 | constrs_b = dep_constr_B_0; 81 | elim_a = dep_elim_A; 82 | elim_b = dep_elim_B; 83 | eta_a = eta_A; 84 | eta_b = eta_B; 85 | iota_a = iota_A_0; 86 | iota_b = iota_B_0 87 | }. 88 | 89 | (* 90 | * Note that since we don't have unification 91 | * heuristics for custom equivalences, for now we'll need to represent the configuration 92 | * terms explicitly everywhere. And also because the transformation tries to transform 93 | * _everything_ that matches, but our dependent constructors take B and A respectively as 94 | * inputs, we need to baby the transformation into understanding when _not_ to lift a B. 95 | * 96 | * So I think the answer here is: technically, we can handle this sort of thing, but when 97 | * it comes to the details of handling it usefully, the usability barriers come up a lot here. 98 | * In particular all of our notes in the paper about the current lack of: 99 | * 1) custom unification heuristics, and 100 | * 2) type-directed search 101 | * become extremely relevant. 102 | *) 103 | Module Over_A. 104 | Definition id (a : A) := a. 105 | 106 | (* 107 | * The swapping can't happen unless we tell the transformation that this: 108 | *) 109 | Definition from_t3_implicit (t3 : T3) : A := fun t1 t2 => t3. 110 | (* 111 | * is an application of dep_constr: 112 | *) 113 | Definition from_t3_explicit (t3 : T3) : A := dep_constr_A_0 (f (fun t1 t2 => t3)). 114 | End Over_A. 115 | 116 | Lemma from_t3_explicit_OK: 117 | Over_A.from_t3_implicit = Over_A.from_t3_explicit. 118 | Proof. 119 | reflexivity. 120 | Defined. 121 | 122 | Lift Module A B in Over_A as Over_B. 123 | Print Over_B.from_t3_explicit. 124 | (* Over_B.from_t3_explicit 125 | : fun (t3 : T3) (_ : T2) (_ : T1) => t3 *) 126 | 127 | 128 | -------------------------------------------------------------------------------- /plugin/coq/playground/index_uip.v: -------------------------------------------------------------------------------- 1 | Add LoadPath "coq/examples". 2 | Require Import Example. 3 | Require Import Vector. 4 | Require Import List. 5 | Require Import Ornamental.Ornaments. 6 | 7 | From Coq Require Import Arith. 8 | 9 | (* syntax to match paper *) 10 | Notation vector := Vector.t. 11 | Notation consV n t v := (Vector.cons _ t n v). 12 | Notation nilV := Vector.nil. 13 | 14 | Set DEVOID search prove coherence. 15 | Set DEVOID search prove equivalence. 16 | Set DEVOID lift type. 17 | 18 | (* Usually, we use this: *) 19 | Definition vanilla_uip 20 | : forall (x y : nat) (p1 p2 : x = y), p1 = p2 21 | := Eqdep_dec.UIP_dec Nat.eq_dec. 22 | 23 | (* 24 | * Okay, now let's try to state and prove a lemma that doens't 25 | * depend on UIP on the type nat, but rather depends 26 | * on the list and vector types. First: 27 | *) 28 | Find ornament list vector as ltv. 29 | 30 | (* 31 | * Next, define the adjoints: 32 | *) 33 | 34 | Definition section_adjoint T := Adjoint.fg_id' (ltv_inv T) (ltv T) (ltv_retraction T) (ltv_section T). 35 | Definition retraction_adjoint T := Adjoint.fg_id' (ltv T) (ltv_inv T) (ltv_section T) (ltv_retraction T). 36 | 37 | Lemma is_adjoint_section T (pv : sigT (vector T)) : ltv_section T (ltv_inv T pv) = f_equal (ltv_inv T) (retraction_adjoint T pv). 38 | Proof. 39 | apply Adjoint.g_adjoint. 40 | Defined. 41 | 42 | Lemma is_adjoint_retraction T (l : list T) : ltv_retraction T (ltv T l) = f_equal (ltv T) (section_adjoint T l). 43 | Proof. 44 | apply Adjoint.g_adjoint. 45 | Defined. 46 | 47 | (* 48 | Lemma mocha_uip : 49 | forall (T : Type) (n : nat) (l : list T) (p1 p2 : projT1 (ltv T l) = ltv_index T l), 50 | p1 = p2. 51 | Proof. 52 | intros T n l. destruct (ltv_coh T l). remember (ltv T l) as s. 53 | 54 | 55 | unfold ltv. simpl. 56 | 57 | remember (ltv T l) as s. induction s. 58 | 59 | Check ltv_coh. 60 | 61 | apply (Eqdep_dec.UIP_dec Nat.eq_dec).*) 62 | 63 | (* Try the Jason thing first: *) 64 | Definition ltv_u (A : Type) (n : nat) (ll : { l : list A & ltv_index A l = n}) : vector A n := 65 | eq_rect 66 | (ltv_index _ (projT1 ll)) 67 | (vector A) 68 | (eq_rect 69 | (projT1 (ltv _ (projT1 ll))) 70 | (vector A) 71 | (projT2 (ltv _ (projT1 ll))) 72 | (ltv_index _ (projT1 ll)) 73 | (ltv_coh _ (projT1 ll))) 74 | n 75 | (projT2 ll). (* ltv_index A l = n *) 76 | 77 | Definition ltv_inv_u (A : Type) (n : nat) (v : vector A n) : { l : list A & ltv_index A l = n} := 78 | existT 79 | (fun (l : list A) => ltv_index _ l = n) 80 | (ltv_inv _ (existT _ n v)) 81 | (eq_rect 82 | (projT1 (ltv A (ltv_inv A (existT _ n v)))) 83 | (fun n0 : nat => n0 = n) 84 | (eq_rect 85 | (existT _ n v) 86 | (fun s : sigT (vector A) => projT1 s = n) 87 | (eq_refl (projT1 (existT _ n v))) 88 | (ltv A (ltv_inv A (existT _ n v))) 89 | (eq_sym (ltv_retraction _ (existT _ n v)))) 90 | (ltv_index _ (ltv_inv _ (existT _ n v))) 91 | (ltv_coh _ (ltv_inv _ (existT _ n v)))). 92 | 93 | Lemma section_u : forall A n v, ltv_inv_u A n (ltv_u A n v) = v. 94 | Proof. 95 | intros A n [l H]; apply eq_sigT_uncurried; subst n. 96 | cbv [ltv_u ltv_inv_u ltv_coh]. 97 | cbn [projT1 projT2 eq_rect]. 98 | change (existT _ (ltv_index A l) (projT2 (ltv A l))) with (ltv A l). 99 | exists (section_adjoint _ _). 100 | rewrite (is_adjoint_retraction A l). 101 | destruct (section_adjoint A l). 102 | reflexivity. 103 | Qed. 104 | 105 | Lemma retraction_u : forall A n v, ltv_u A n (ltv_inv_u A n v) = v. 106 | Proof. 107 | cbv [ltv_u ltv_inv_u]. 108 | cbn [projT1 projT2]. 109 | intros. 110 | set (p := ltv_retraction A (existT _ n v)). 111 | set (q := ltv_coh _ _). 112 | clearbody p q. 113 | cbv beta in *. 114 | generalize dependent (ltv A (ltv_inv A (existT _ n v))). 115 | intros [x y] p q. 116 | cbn [projT1 projT2] in *. 117 | subst x. 118 | inversion_sigma. 119 | repeat match goal with H : _ = ?v |- _ => is_var v; destruct H end. 120 | reflexivity. 121 | Qed. 122 | 123 | 124 | (* So, what variant of UIP do we get this way? It should be in the proof of section somewhere. *) 125 | (* TODO WIP, see issue 39 *) 126 | 127 | Definition zip := packed_list.zip. 128 | Definition zip_with := packed_list.zip_with. 129 | 130 | Lemma uip_instance: 131 | forall (A B : Type) (n : nat) 132 | (l : list A) (H : hs_to_coqV_p.list_to_t_index A l = n) 133 | (pl2 : {l2 : list B & length l2 = n}), 134 | eq_rect 135 | (hs_to_coq.zip_with A B (A * B) pair l (projT1 pl2)) 136 | (fun l3 : list (A * B) => length l3 = n) 137 | (packed_list.zip_with_length A B (A * B) pair n l (projT1 pl2) (id H) (projT2 pl2)) 138 | (hs_to_coq.zip A B l (projT1 pl2)) 139 | (hs_to_coq.zip_with_is_zip A B l (projT1 pl2)) = 140 | packed_list.zip_length A B n l (projT1 pl2) (id H) (projT2 pl2). 141 | Proof. 142 | intros. 143 | apply (Eqdep_dec.UIP_dec Nat.eq_dec). (* <- what we want to replace *) 144 | Defined. 145 | 146 | Lemma zip_with_is_zip : 147 | forall A B n (pl1 : { l1 : list A & length l1 = n }) (pl2 : { l2 : list B & length l2 = n }), 148 | zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2. 149 | Proof. 150 | intros A B n pl1. 151 | apply packed_list_rect with (P := fun (pl1 : {l1 : list A & length l1 = n}) => forall pl2 : {l2 : list B & length l2 = n}, zip_with A B (A * B) pair n pl1 pl2 = zip A B n pl1 pl2). 152 | intros l H pl2. 153 | unfold zip_with, zip, packed_list_rect, hs_to_coqV_p.list_to_t_rect, packed_rect. simpl. 154 | apply eq_existT_uncurried. 155 | (* list proof: *) 156 | exists (hs_to_coq.zip_with_is_zip A B l (projT1 pl2)). 157 | (* length invariant: *) 158 | apply uip_instance. 159 | Defined. -------------------------------------------------------------------------------- /plugin/coq/playground/refine_unit.v: -------------------------------------------------------------------------------- 1 | (* 2 | * This proof shows that, given some type A, you can always prove an equivalence 3 | * with unit refined by A. Thus, by transitivity of equivalences (not proven here), 4 | * if A is equivalent to B, then so is unit refined by A. 5 | * 6 | * In the context of the paper, this gives an example of a construction that allows for 7 | * the formation of infinitely many (just keep adding unit) useless (subjectively, in 8 | * the authors' opinions) equivalences corresponding to a change from A to B. This again 9 | * makes the point that choosing a useful equivalence is important and is a bit of an art. 10 | *) 11 | 12 | Definition uA (A : Type) := sigT (fun u : unit => A). 13 | 14 | Definition f (A : Type) (a : A) : uA A := 15 | existT _ tt a. 16 | 17 | Definition g (A : Type) (ua : uA A) : A := 18 | projT2 ua. 19 | 20 | Lemma section: forall A a, g A (f A a) = a. 21 | Proof. 22 | intros. reflexivity. 23 | Defined. 24 | 25 | Lemma retraction: forall A u, f A (g A u) = u. 26 | Proof. 27 | intros. induction u. induction x. reflexivity. 28 | Defined. 29 | -------------------------------------------------------------------------------- /plugin/coq/playground/trivial.v: -------------------------------------------------------------------------------- 1 | (* 2 | * It makes more sense to prove this quickly in a Coq file than explain it in text. 3 | * This is to clear something up for reviews. 4 | * 5 | * Equivalences do capture the set of all changes that one can make to a type, 6 | * including semantic changes, just not in a way that is practically useful! 7 | * So the challenge is determining when _useful_, _nontrivial_ equivalences exist 8 | * that separate out new information into a projection of the sigma type, 9 | * and then writing good interfaces for getting that new information. 10 | *) 11 | 12 | Module Rudamentary. 13 | (* 14 | * Here is the proof of the rudamentary case. Fix T1 and T2 arbitrary: 15 | *) 16 | Parameter T1 : Type. 17 | Parameter T2 : Type. 18 | 19 | (* 20 | * In the case that T1 and T2 are completely distinct, the new information 21 | * for T1 will be all of T2, and the new information for T2 will be all of T1. 22 | * Accordingly: 23 | *) 24 | Definition A := sigT (fun (t2 : T2) => T1). 25 | Definition B := sigT (fun (t1 : T1) => T2). 26 | 27 | (* 28 | * Then: 29 | *) 30 | Definition f (a : A) : B := existT _ (projT2 a) (projT1 a). 31 | Definition g (b : B) : A := existT _ (projT2 b) (projT1 b). 32 | 33 | Lemma section: forall a, g (f a) = a. 34 | Proof. 35 | intros. induction a. unfold g, f. reflexivity. 36 | Defined. 37 | 38 | Lemma retraction: forall b, f (g b) = b. 39 | Proof. 40 | intros. induction b. unfold f, g. reflexivity. 41 | Defined. 42 | End Rudamentary. 43 | 44 | (* 45 | * Of course, this is not useful! It doesn't make things any easier for the 46 | * user at all. But it captures the rudimentary most difficult case when 47 | * the types are totally distinct. It says, if you want proofs about T2, 48 | * and you have proofs about T1, you need to write proofs about T2 (obviously), 49 | * and that will give you proofs about T2 given T1 (of course). 50 | * 51 | * In more useful cases, the sigma will show up on just one side. 52 | * This is seen in the example change with algebraic ornaments, and that is one 53 | * we can handle usefully. 54 | * 55 | * But there are some like this that are possible but still not useful. 56 | * One example of this is going between natural numbers 57 | * and lists---the only way to do this is to provide enough information to 58 | * construct a vector. Trivially, we can ask the user to prove things over vectors 59 | * as the new proof obligation, but this is obviously harder than just writing 60 | * proofs about lists to begin with. So if we want to support this case usefully, 61 | * the key challenge becomes presenting an interface to the user that prompts 62 | * them to provide enough information to construct a proof about vectors given a 63 | * proof about natural numbers, but is easier to work with than asking for 64 | * the vector proof directly, and easier than working with lists. We don't 65 | * know if this is possible. The same goes for adding new constructors. 66 | * 67 | * The point here is that any question about scope really needs to ask about 68 | * the set of changes we can handle _usefully_, which is tied to the set of 69 | * changes we evaluate on real code and proofs. This is why we focused on 70 | * evaluating some cases and omitted the ones we knew we could handle in trivial 71 | * ways, but we did not yet know if we could handle in useful ways. This was 72 | * probably not explicit enough, so we will need to make this more explicit. 73 | *) 74 | -------------------------------------------------------------------------------- /plugin/coq/prod_rect.v: -------------------------------------------------------------------------------- 1 | From Ornamental Require Import Ornaments. 2 | Require Import Infrastructure. 3 | 4 | Set DEVOID search prove equivalence. 5 | Set DEVOID lift type. 6 | Set Nonrecursive Elimination Schemes. 7 | 8 | (* 9 | * This code is a minimized example from @ptival, which I use as a regression test 10 | * to make sure projections aren't expanded and left as applications of prod_rect, 11 | * and that projections/accessors lift to accessors/projections. 12 | * 13 | * The proofs here are purposely brittle, since they should break if the terms are not _exactly_ syntactically equal. 14 | *) 15 | 16 | Module Pairs. 17 | 18 | Definition profile : Type := (bool * nat). 19 | 20 | Definition page : Type := (nat * (nat * (bool * ((bool * nat) * nat)))). 21 | 22 | Definition visible (pr : profile) (pa : page) : bool := 23 | andb (fst pr) (fst (snd (snd pa))). 24 | 25 | End Pairs. 26 | 27 | Preprocess Module Pairs as Pairs_PP { opaque andb }. 28 | 29 | Module Records. 30 | 31 | Record Profile := 32 | { 33 | public : bool; 34 | age : nat; 35 | }. 36 | 37 | Definition is_public (pr : Pairs.profile) : bool := fst pr. 38 | 39 | Definition get_age (pr : Pairs.profile) : nat := snd pr. 40 | 41 | End Records. 42 | 43 | Preprocess Module Records as Records_PP. 44 | 45 | Lift Records_PP.Profile Pairs_PP.profile in Records_PP.public as is_public. 46 | Lift Pairs_PP.profile Records_PP.Profile in Records_PP.is_public as public. 47 | 48 | Definition is_public_expected (h : Pairs_PP.profile) := 49 | Prod.fst _ _ h. 50 | 51 | Lemma test_is_public: 52 | is_public = is_public_expected. 53 | Proof. 54 | unfold is_public, is_public_expected. 55 | test_exact_equality. 56 | Qed. 57 | 58 | Lemma test_public: 59 | public = fun h => Records_PP.public h. 60 | Proof. 61 | unfold public. 62 | test_exact_equality. 63 | Qed. 64 | 65 | Lift Records_PP.Profile Pairs_PP.profile in Records_PP.age as get_age. 66 | Lift Pairs_PP.profile Records_PP.Profile in Records_PP.get_age as age. 67 | 68 | Definition get_age_expected (h : Pairs_PP.profile) := 69 | Prod.snd _ _ h. 70 | 71 | Lemma test_get_h_n: 72 | get_age = get_age_expected. 73 | Proof. 74 | unfold get_age, get_age_expected. 75 | test_exact_equality. 76 | Qed. 77 | 78 | Lemma testGetHN: 79 | age = fun (h : Records_PP.Profile) => Records_PP.age h. 80 | Proof. 81 | unfold age. 82 | test_exact_equality. 83 | Qed. 84 | 85 | Lift Pairs_PP.profile Records_PP.Profile in Pairs_PP.visible as visible_PP { opaque andb }. 86 | 87 | Definition visible_PP_expected (pr : Records_PP.Profile) (pa : nat * (nat * (bool * (Records_PP.Profile * nat)))) : bool := 88 | Records_PP.public pr 89 | && 90 | Pairs_PP.Coq_Init_Datatypes_fst bool (Records_PP.Profile * nat) 91 | (Pairs_PP.Coq_Init_Datatypes_snd nat (bool * (Records_PP.Profile * nat)) 92 | (Pairs_PP.Coq_Init_Datatypes_snd nat (nat * (bool * (Records_PP.Profile * nat))) pa)). 93 | 94 | Lemma test_visible_PP: 95 | visible_PP = visible_PP_expected. 96 | Proof. 97 | unfold visible_PP, visible_PP_expected. 98 | test_exact_equality. 99 | Qed. 100 | 101 | Module MoreRecords. 102 | 103 | Record Page := 104 | { 105 | friends : nat; 106 | groups : nat; 107 | active : bool; 108 | profile : Records_PP.Profile; 109 | photos : nat; 110 | }. 111 | 112 | (* We'd like to wrap the ugly access into this: *) 113 | Definition is_active (pa : Pairs.page) : bool := fst (snd (snd pa)). 114 | 115 | End MoreRecords. 116 | 117 | Preprocess Module MoreRecords as MoreRecords_PP. 118 | 119 | Lift Pairs_PP.profile Records_PP.Profile in Pairs_PP.page as page_PP. 120 | 121 | Lift Pairs_PP.profile Records_PP.Profile in MoreRecords_PP.is_active as active0. 122 | Lift page_PP MoreRecords_PP.Page in active0 as active. 123 | 124 | Lift Pairs_PP.profile Records_PP.Profile in Pairs_PP.visible as visible0 { opaque andb }. 125 | Lift page_PP MoreRecords_PP.Page in visible0 as visible { opaque andb }. 126 | 127 | Definition visible_expected (pr : Records_PP.Profile) (pa : MoreRecords_PP.Page) : bool := 128 | (Records_PP.public pr && MoreRecords_PP.active pa)%bool. 129 | 130 | Lemma test_visible : 131 | visible = visible_expected. 132 | Proof. 133 | unfold visible, visible_expected. 134 | test_exact_equality. 135 | Qed. 136 | -------------------------------------------------------------------------------- /plugin/eval/Makefile: -------------------------------------------------------------------------------- 1 | main.vo: main.v lemmas.vo cast.vo 2 | coqc main.v 3 | 4 | lemmas.vo: lemmas.v 5 | coqc lemmas.v 6 | 7 | cast.vo: cast.v 8 | coqc cast.v 9 | 10 | clean: 11 | rm -f *.vo *.glob 12 | 13 | together: main2.v lemmas.vo cast.vo 14 | coqc main2.v 15 | 16 | 17 | -------------------------------------------------------------------------------- /plugin/eval/cast.v: -------------------------------------------------------------------------------- 1 | Notation cast p E := (@eq_rect _ _ _ p _ E). 2 | 3 | Lemma cast_sigma {A : Type} {B : A -> Type} {C : Type} {x y : A} 4 | (f : forall x, B x -> C) (E : x = y) 5 | (p : B x) : f y (cast p E) = f x p. 6 | Proof. 7 | revert p. rewrite <- E. intro p. reflexivity. 8 | Defined. 9 | -------------------------------------------------------------------------------- /plugin/eval/equiv4free/Makefile: -------------------------------------------------------------------------------- 1 | lemmas.vo: lemmas.v perm.vo list.vo 2 | coqc lemmas.v 3 | 4 | perm.vo: perm.v list.vo 5 | coqc perm.v 6 | 7 | list.vo: list.v 8 | coqc list.v 9 | 10 | clean: 11 | rm -f *.vo *.glob 12 | 13 | equiv: main2.v lemmas.vo perm.vo list.vo 14 | coqc main2.v 15 | 16 | -------------------------------------------------------------------------------- /plugin/eval/equiv4free/cast.v: -------------------------------------------------------------------------------- 1 | Notation cast p E := (@eq_rect _ _ _ p _ E). 2 | 3 | Lemma cast_sigma {A : Type} {B : A -> Type} {C : Type} {x y : A} 4 | (f : forall x, B x -> C) (E : x = y) 5 | (p : B x) : f y (cast p E) = f x p. 6 | Proof. 7 | revert p. rewrite <- E. intro p. reflexivity. 8 | Defined. 9 | -------------------------------------------------------------------------------- /plugin/eval/equiv4free/lemmas.v: -------------------------------------------------------------------------------- 1 | From UnivalentParametricity Require Import HoTT FP. 2 | Require Import list perm. 3 | 4 | Set Universe Polymorphism. 5 | 6 | Notation permutes := Permutation. 7 | Notation perm_sym := Permutation_sym. 8 | Notation perm_app := Permutation_app. 9 | Notation perm_app_comm := Permutation_app_comm. 10 | Notation perm_cons_app := Permutation_cons_app. 11 | 12 | Lemma add_Sn_m (n m : nat) : S n + m = S (n + m). 13 | Proof. reflexivity. Defined. 14 | 15 | Lemma add_n_Sm (n m : nat) : n + S m = S (n + m). 16 | Proof. 17 | revert m. induction n; intro m; try reflexivity. 18 | rewrite add_Sn_m, add_Sn_m, IHn. reflexivity. 19 | Defined. 20 | 21 | Lemma add_n_O (n : nat) : n + O = n. 22 | Proof. 23 | induction n; try reflexivity. rewrite add_Sn_m, IHn. reflexivity. 24 | Defined. 25 | 26 | Lemma add_comm (n m : nat) : n + m = m + n. 27 | Proof. 28 | revert m. induction n; intro m. 29 | - rewrite add_n_O. reflexivity. 30 | - rewrite add_Sn_m, add_n_Sm, IHn. reflexivity. 31 | Defined. 32 | 33 | Lemma max_comm (n m : nat) : Nat.max n m = Nat.max m n. 34 | Proof. 35 | revert m. induction n; destruct m; try reflexivity. 36 | simpl. rewrite IHn. reflexivity. 37 | Defined. 38 | -------------------------------------------------------------------------------- /plugin/eval/equiv4free/prepermutes.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # Once you have uncommented the extremely costly normalization in main.v, this script normalizes it. 4 | 5 | if [ -e ../out ] 6 | then 7 | rm -r ../out 8 | else 9 | : 10 | fi 11 | 12 | if [ -e main2.v ] 13 | then 14 | rm main2.v 15 | else 16 | : 17 | fi 18 | 19 | mkdir ../out 20 | mkdir ../out/inputs 21 | mkdir ../out/inorder 22 | mkdir ../out/postorder 23 | mkdir ../out/preorder 24 | mkdir ../out/search 25 | mkdir ../out/equivalences 26 | mkdir ../out/normalized 27 | cp main.v main2.v 28 | 29 | # Remake DEVOID case study code exactly once, to print terms 30 | cd .. 31 | make clean 32 | make 33 | 34 | # Copy the produced equivalences into the EFF code 35 | for f in $(find out/equivalences/*.out); do 36 | name=$(basename "${f%.*}") 37 | line=$(grep -n " : forall" $f | cut -d : -f 1) 38 | head -n $(($line-1)) $f > out/equivalences/$name-notyp.out 39 | dirname=$(echo $name | cut -d '-' -f 1) 40 | suffix=$(echo $name | cut -d '-' -f 2) 41 | defname=$dirname 42 | sed -i "s/$defname =/Definition $defname :=/" out/equivalences/$name-notyp.out 43 | echo "." >> out/equivalences/$name-notyp.out 44 | term=$(cat out/equivalences/$name-notyp.out) 45 | 46 | # https://stackoverflow.com/questions/29613304/is-it-possible-to-escape-regex-metacharacters-reliably-with-sed 47 | IFS= read -d '' -r < <(sed -e ':a' -e '$!{N;ba' -e '}' -e 's/[&/\]/\\&/g; s/\n/\\&/g' <<<"$term") 48 | term=${REPLY%$'\n'} 49 | 50 | sed -i "s/(\* EQUIV $name \*)/$term/" equiv4free/main2.v 51 | done 52 | 53 | # Copy the produced inputs into the EFF code 54 | for f in $(find out/inputs/*.out); do 55 | name=$(basename "${f%.*}") 56 | line=$(grep -n " :" $f | cut -d : -f 1) 57 | head -n $(($line-1)) $f > out/inputs/$name-notyp.out 58 | dirname=$(echo $name | cut -d '-' -f 1) 59 | suffix=$(echo $name | cut -d '-' -f 2) 60 | defname=$dirname 61 | sed -i "s/$defname =/Definition $defname :=/" out/inputs/$name-notyp.out 62 | echo "." >> out/inputs/$name-notyp.out 63 | term=$(cat out/inputs/$name-notyp.out) 64 | 65 | # https://stackoverflow.com/questions/29613304/is-it-possible-to-escape-regex-metacharacters-reliably-with-sed 66 | IFS= read -d '' -r < <(sed -e ':a' -e '$!{N;ba' -e '}' -e 's/[&/\]/\\&/g; s/\n/\\&/g' <<<"$term") 67 | term=${REPLY%$'\n'} 68 | 69 | sed -i "s/(\* INPUT $name \*)/$term/" equiv4free/main2.v 70 | done 71 | 72 | # Remake Univalent Parametricity case study code 73 | cd equiv4free 74 | make clean 75 | 76 | echo "grab a coffee or a book; this will take a bit once you've uncommented the right line" 77 | timeout 1h `time make equiv` 78 | 79 | # Measure normalized term size 80 | for f in $(find ../out/normalized/pre_permutes-sizedEFFequiv.out); do 81 | name=$(basename "${f%.*}") 82 | line=$(grep -n " : forall" $f | cut -d : -f 1) 83 | head -n $(($line-1)) $f > ../out/normalized/$name-notyp.out 84 | coqwc -s ../out/normalized/$name-notyp.out 85 | done 86 | 87 | 88 | -------------------------------------------------------------------------------- /plugin/eval/lemmas.v: -------------------------------------------------------------------------------- 1 | Require Import Sorting.Permutation. 2 | 3 | Notation permutes := Permutation. 4 | Notation perm_sym := Permutation_sym. 5 | Notation perm_app := Permutation_app. 6 | Notation perm_app_comm := Permutation_app_comm. 7 | Notation perm_cons_app := Permutation_cons_app. 8 | 9 | Lemma add_Sn_m (n m : nat) : S n + m = S (n + m). 10 | Proof. reflexivity. Defined. 11 | 12 | Lemma add_n_Sm (n m : nat) : n + S m = S (n + m). 13 | Proof. 14 | revert m. induction n; intro m; try reflexivity. 15 | rewrite add_Sn_m, add_Sn_m, IHn. reflexivity. 16 | Defined. 17 | 18 | Lemma add_n_O (n : nat) : n + O = n. 19 | Proof. 20 | induction n; try reflexivity. rewrite add_Sn_m, IHn. reflexivity. 21 | Defined. 22 | 23 | Lemma add_comm (n m : nat) : n + m = m + n. 24 | Proof. 25 | revert m. induction n; intro m. 26 | - rewrite add_n_O. reflexivity. 27 | - rewrite add_Sn_m, add_n_Sm, IHn. reflexivity. 28 | Defined. 29 | 30 | Lemma max_comm (n m : nat) : Nat.max n m = Nat.max m n. 31 | Proof. 32 | revert m. induction n; destruct m; try reflexivity. 33 | simpl. f_equal. apply IHn. 34 | Defined. 35 | -------------------------------------------------------------------------------- /plugin/eval/times.sed: -------------------------------------------------------------------------------- 1 | # Used to format time measurements from Coq 2 | s/[.]\([0-9][0-9][1-9]\) /\1 /; 3 | s/[.]\([0-9][1-9]\) /\10 /; 4 | s/[.]\([0-9]\) /\100 /; 5 | s/[.] /000 /; 6 | s/^0*\([1-9][0-9]*\) secs/\1/; 7 | s/^0* secs/0/; 8 | -------------------------------------------------------------------------------- /plugin/eval/together.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | # This runs the second of two versions of the eval, which is the version of the eval in the paper; 4 | # it uses the same datatypes for both and copies and pastes the function, 5 | # to control for changes in performance between regular Coq and Coq with EFF. 6 | 7 | if [ -e out ] 8 | then 9 | rm -r out 10 | else 11 | : 12 | fi 13 | 14 | if [ -e results ] 15 | then 16 | rm -r results 17 | else 18 | : 19 | fi 20 | 21 | if [ -e main2.v ] 22 | then 23 | rm main2.v 24 | else 25 | : 26 | fi 27 | 28 | if [ -e equiv4free/main2.v ] 29 | then 30 | rm equiv4free/main2.v 31 | else 32 | : 33 | fi 34 | 35 | mkdir out 36 | mkdir out/inorder 37 | mkdir out/postorder 38 | mkdir out/preorder 39 | mkdir out/search 40 | mkdir out/inputs 41 | mkdir out/equivalences 42 | mkdir out/normalized 43 | mkdir results 44 | mkdir results/inorder 45 | mkdir results/postorder 46 | mkdir results/preorder 47 | mkdir results/search 48 | cp main.v main2.v 49 | cp equiv4free/main.v equiv4free/main2.v 50 | 51 | # Set DEVOID case study code to print regular terms instead of computed ones 52 | sed -i "s/Eval compute in/Print/" main2.v 53 | 54 | # Remake DEVOID case study code exactly once, to print terms 55 | make clean 56 | make together 57 | 58 | # Copy the produced equivalences into the EFF code 59 | for f in $(find out/equivalences/*.out); do 60 | name=$(basename "${f%.*}") 61 | line=$(grep -n " : forall" $f | cut -d : -f 1) 62 | head -n $(($line-1)) $f > out/equivalences/$name-notyp.out 63 | dirname=$(echo $name | cut -d '-' -f 1) 64 | suffix=$(echo $name | cut -d '-' -f 2) 65 | defname=$dirname 66 | sed -i "s/$defname =/Definition $defname :=/" out/equivalences/$name-notyp.out 67 | echo "." >> out/equivalences/$name-notyp.out 68 | term=$(cat out/equivalences/$name-notyp.out) 69 | 70 | # https://stackoverflow.com/questions/29613304/is-it-possible-to-escape-regex-metacharacters-reliably-with-sed 71 | IFS= read -d '' -r < <(sed -e ':a' -e '$!{N;ba' -e '}' -e 's/[&/\]/\\&/g; s/\n/\\&/g' <<<"$term") 72 | term=${REPLY%$'\n'} 73 | 74 | sed -i "s/(\* EQUIV $name \*)/$term/" equiv4free/main2.v 75 | done 76 | 77 | # Copy the produced inputs into the EFF code 78 | for f in $(find out/inputs/*.out); do 79 | name=$(basename "${f%.*}") 80 | line=$(grep -n " :" $f | cut -d : -f 1) 81 | head -n $(($line-1)) $f > out/inputs/$name-notyp.out 82 | dirname=$(echo $name | cut -d '-' -f 1) 83 | suffix=$(echo $name | cut -d '-' -f 2) 84 | defname=$dirname 85 | sed -i "s/$defname =/Definition $defname :=/" out/inputs/$name-notyp.out 86 | echo "." >> out/inputs/$name-notyp.out 87 | term=$(cat out/inputs/$name-notyp.out) 88 | 89 | # https://stackoverflow.com/questions/29613304/is-it-possible-to-escape-regex-metacharacters-reliably-with-sed 90 | IFS= read -d '' -r < <(sed -e ':a' -e '$!{N;ba' -e '}' -e 's/[&/\]/\\&/g; s/\n/\\&/g' <<<"$term") 91 | term=${REPLY%$'\n'} 92 | 93 | sed -i "s/(\* INPUT $name \*)/$term/" equiv4free/main2.v 94 | done 95 | 96 | 97 | # Copy the produced terms into the EFF code, to run everything together 98 | for f in $(find out/normalized/*.out); do 99 | name=$(basename "${f%.*}") 100 | line=$(grep -n " : forall" $f | cut -d : -f 1) 101 | head -n $(($line-1)) $f > out/normalized/$name-notyp.out 102 | dirname=$(echo $name | cut -d '-' -f 1) 103 | suffix=$(echo $name | cut -d '-' -f 2) 104 | defname=$dirname"'" 105 | sed -i "s/$defname =/Definition $defname :=/" out/normalized/$name-notyp.out 106 | echo "." >> out/normalized/$name-notyp.out 107 | term=$(cat out/normalized/$name-notyp.out) 108 | 109 | # https://stackoverflow.com/questions/29613304/is-it-possible-to-escape-regex-metacharacters-reliably-with-sed 110 | IFS= read -d '' -r < <(sed -e ':a' -e '$!{N;ba' -e '}' -e 's/[&/\]/\\&/g; s/\n/\\&/g' <<<"$term") 111 | term=${REPLY%$'\n'} 112 | 113 | sed -i "s/(\* DEF $name \*)/$term/" equiv4free/main2.v 114 | sed -i "s/(\* NORMALIZE $name \*)/Redirect \"..\/out\/normalized\/$name\" Eval compute in $defname./" equiv4free/main2.v 115 | 116 | sed -i "s/(\* TIME-SEARCH $name \*)/Redirect \"..\/out\/$dirname\/${suffix}1\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree1 Elem.x in (hide foo) ).\n\tRedirect \"..\/out\/$dirname\/${suffix}10\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree10 Elem.x in (hide foo) ).\n\tRedirect \"..\/out\/$dirname\/${suffix}100\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree100 Elem.x in (hide foo) ).\n\tRedirect \"..\/out\/$dirname\/${suffix}1000\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree1000 Elem.x in (hide foo) ).\n\tRedirect \"..\/out\/$dirname\/${suffix}10000\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree10000 Elem.x in (hide foo) ).\n\tRedirect \"..\/out\/$dirname\/${suffix}100000\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree100000 Elem.x in (hide foo) )./" equiv4free/main2.v 117 | 118 | sed -i "s/(\* TIME-AVL $name \*)/Redirect \"..\/out\/$dirname\/${suffix}1\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree1 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}10\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree10 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}100\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree100 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}1000\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree1000 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}10000\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree10000 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}100000\" Time Eval vm_compute in (let foo := $defname _ _ _ _ tree100000 in (hide foo))./" equiv4free/main2.v 119 | 120 | sed -i "s/(\* TIME-SIZED $name \*)/Redirect \"..\/out\/$dirname\/${suffix}1\" Time Eval vm_compute in (let foo := $defname tree1 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}10\" Time Eval vm_compute in (let foo := $defname tree10 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}100\" Time Eval vm_compute in (let foo := $defname tree100 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}1000\" Time Eval vm_compute in (let foo := $defname tree1000 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}10000\" Time Eval vm_compute in (let foo := $defname tree10000 in (hide foo)).\n\tRedirect \"..\/out\/$dirname\/${suffix}100000\" Time Eval vm_compute in (let foo := $defname tree100000 in (hide foo))./" equiv4free/main2.v 121 | done 122 | 123 | # Clean outputted directories 124 | rm -r out 125 | mkdir out 126 | mkdir out/inorder 127 | mkdir out/postorder 128 | mkdir out/preorder 129 | mkdir out/search 130 | mkdir out/normalized 131 | 132 | # Run ten iterations of comparison 133 | for i in {1..10} 134 | do 135 | echo "Run #${i}" 136 | 137 | # Remake Univalent Parametricity case study code 138 | cd equiv4free 139 | make clean 140 | make equiv 141 | cd .. 142 | 143 | # Add the computation times to the aggregate files 144 | for f in $(find out/*/*.out); do 145 | name=$(basename "${f%.*}") 146 | dirname=$(dirname "${f%.*}" | cut -d / -f 2) 147 | if [ $dirname == "normalized" ] || [ $dirname == "equivalences" ] 148 | then 149 | : 150 | else 151 | tail -n 2 $f | grep -o -e '[0-9.]* secs' | sed -f times.sed >> results/$dirname/$name.out 152 | fi 153 | done 154 | done 155 | 156 | # Add the distribution data 157 | for f in $(find results/*/*.out); do 158 | name=$(dirname "${f%.*}" | cut -d / -f 2)"-"$(basename "${f%.*}") 159 | data=$(datamash median 1 < $f) 160 | echo "$name : $data" >> results/medians.out 161 | done 162 | 163 | # Measure normalized term size 164 | for f in $(find out/normalized/*.out); do 165 | name=$(basename "${f%.*}") 166 | line=$(grep -n " : forall" $f | cut -d : -f 1) 167 | head -n $(($line-1)) $f > out/normalized/$name-notyp.out 168 | loc=$(coqwc -s out/normalized/$name-notyp.out) 169 | echo $loc >> results/sizes.out 170 | done 171 | 172 | # Format term size data 173 | sed -i "s/out\/normalized\///" results/sizes.out 174 | sed -i "s/-notyp.out//" results/sizes.out 175 | 176 | # Clean temporary files 177 | rm -r out 178 | rm main2.v 179 | rm equiv4free/main2.v # You can comment out this line if you want to see the output file with everything together 180 | 181 | -------------------------------------------------------------------------------- /plugin/src/automation/depelim.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Dependent elimination for inductive families over sigma-packed indices. 3 | *) 4 | 5 | open Util 6 | open Constr 7 | open Nameops 8 | open Declarations 9 | open Apputils 10 | open Sigmautils 11 | 12 | (* 13 | * Given a relative context quantifying an inductive family's indices, assemble 14 | * the list of `constr` arguments to supply the inductive family's type former, 15 | * such that the argument for any index of sigma type is its eta-expansion. 16 | * 17 | * As an example, an `index_ctxt` of `[("x" : bool); ("y" : sigT vector)]` 18 | * becomes `[@1; existT vector (projT1 @2) (projT2 @2)]`, denoting each `Rel i` 19 | * as `@i`. Notice how each argument lives directly underneath `index_ctxt`. 20 | * 21 | * NOTE: Assumes that all parameter's of the inductive family are externally 22 | * quantified (i.e., above `index_ctxt`) and are thus effectively fixed. 23 | * 24 | * NOTE: Requires that the list of index arguments be used directly under the 25 | * local bindings (i.e., quantifiers) of `index_ctxt`, due to deBruijn indexing. 26 | *) 27 | let eta_expand_indices index_ctxt = 28 | List.map_i 29 | (fun k (_, typ) -> 30 | let typ = Vars.lift k typ in 31 | if applies sigT typ then eta_sigT (mkRel k) typ else mkRel k) 32 | 1 33 | index_ctxt 34 | 35 | (* 36 | * Given an "arity" `typ` w.r.t. an inductive family over `nindex` indices, 37 | * substitute each bound index (i.e., `Rel i` for `i` s.t. `1 <= i <= nindex`) 38 | * with its eta-expansion w.r.t. the sigma type `sigT`, if applicable. 39 | * 40 | * The `nindex` quantifiers, which prefix the arity `typ`, are opened for the 41 | * above substitution and then closed in the result. 42 | * 43 | * NOTE: An "arity", in the context of inductive families, is a type quantifying 44 | * all an inductive family's indices (in order), followed by some codomain type. 45 | * For example, `forall (n : nat), Type` is an arity w.r.t. `vector`. 46 | *) 47 | let eta_expand_arity nindex typ = 48 | let index_ctxt, body = Term.decompose_prod_n nindex typ in 49 | let indices = eta_expand_indices index_ctxt in 50 | Vars.liftn nindex (nindex + 1) body |> Vars.substl indices |> 51 | Term.compose_prod index_ctxt 52 | 53 | (* 54 | * Given the underlying eliminator's motive type, construct the motive term for 55 | * the wrapped eliminator to apply to that same underlying eliminator. 56 | * 57 | * This motive term is an eta expansion of that quantified, except that each 58 | * index to the inductive family is eliminated via `sigT_rect`, if applicable. 59 | * 60 | * By wrapping the quantified motive in this way, the user may (ultimately) 61 | * supply, to the wrapped eliminator, a motive term that relies on eta expansion 62 | * for sigma types. 63 | * 64 | * NOTE: Assumes that the result term lives underneath the wrapped eliminator's 65 | * full series of quantifiers (i.e., parameters, then motive, then indices). 66 | *) 67 | let eta_guard_motive ncons nindex typ = 68 | let rec aux i typ = 69 | if i == nindex then 70 | let motive = mkRel (nindex + nindex + ncons + 1) in 71 | let indices = Termops.rel_vect 0 nindex in 72 | mkApp (motive, indices) 73 | else 74 | let name, domain, codomain = destProd typ in 75 | let body = aux (i + 1) codomain in 76 | if applies sigT domain then 77 | let body = 78 | let domain = Vars.lift 2 domain in 79 | let { index_type; packer } = dest_sigT domain in 80 | mkLetIn 81 | (name, 82 | mkApp (existT, [|index_type; packer; mkRel 2; mkRel 1|]), 83 | domain, 84 | Vars.liftn 2 2 body) 85 | in 86 | let { index_type; packer } = dest_sigT domain in 87 | let packed_type = Reduction.beta_app (Vars.lift 1 packer) (mkRel 1) in 88 | let name_1 = Name.map (fun id -> add_suffix id "_1") name in 89 | let name_2 = Name.map (fun id -> add_suffix id "_2") name in 90 | mkApp 91 | (sigT_rect, 92 | [|index_type; packer; 93 | mkLambda (name, domain, codomain); 94 | mkLambda (name_1, index_type, 95 | mkLambda (name_2, packed_type, body))|]) 96 | else 97 | mkLambda (name, domain, body) 98 | in 99 | Vars.lift (ncons + nindex + 1) typ |> aux 0 100 | 101 | (* 102 | * Construct a wrapper term around an inductive family's (given as a 103 | * `mind_specif`) eliminator (given as a constant `constr` reference with its 104 | * `types`), returning both the wrapper `constr` and its "natural" `types`. 105 | * 106 | * The wrapper term resembles an eta-expansion of the underlying eliminator, 107 | * except that the applied motive is also an eta-expansion in which any index 108 | * of sigma type is definitionally eta-expanded. The net effect is that the 109 | * wrapped eliminator accepts a motive expecting definitional eta-expansion 110 | * of indices with sigma type. 111 | * 112 | * The wrapped eliminator can be understood as enabling implicit dependent 113 | * elimination for the inductive family w.r.t. its indices of sigma type. 114 | * Since the canonical form of a sigma type is irrefutable, this (fairly) 115 | * simple instance of dependent elimination does not need to rely on any 116 | * extra axiom or any special (proof of a) property like UIP. 117 | * 118 | * NOTE: Using the returned `types` is not strictly necessary, but it is much 119 | * more readable than that inferred by type-checking. 120 | *) 121 | let eta_guard_eliminator (mind_body, ind_body) elim_term elim_type = 122 | (* NOTE: The control flow here follows the structure of `elim_type`. *) 123 | let nparam = mind_body.mind_nparams in 124 | let nindex = ind_body.mind_nrealargs in 125 | let ncons = Array.length ind_body.mind_consnames in 126 | (* Pull off the `nparam` quantifiers for the inductive family's parameters. *) 127 | let param_ctxt, typ = Term.decompose_prod_n nparam elim_type in 128 | (* Pull off the quantifier for the elimination motive. *) 129 | let motive_name, motive_type, typ = destProd typ in 130 | (* Pull off the `ncons` quantifiers for the constructor recurrences. *) 131 | let recur_ctxt, typ = Term.decompose_prod_n ncons typ in 132 | (* Eta-expand any indices of sigma type found in the elimination arity. *) 133 | let elim_arity = eta_expand_arity nindex typ in 134 | (* Pull of the `nindex` quantifiers for the inductive family's indices. *) 135 | let index_ctxt, typ = Term.decompose_prod_n nindex elim_arity in 136 | (* Assemble the full series of quantifiers for the wrapped eliminator. *) 137 | let context = 138 | (* Eta-expand any indices of sigma type found in the motive arity. *) 139 | let motive_decl = (motive_name, eta_expand_arity nindex motive_type) in 140 | List.concat [index_ctxt; recur_ctxt; [motive_decl]; param_ctxt] 141 | in 142 | (* Assemble the full series of arguments for the underlying eliminator. *) 143 | let arguments = 144 | (* Collect the `nparam` parameters bound in `context`. *) 145 | let params = Termops.rel_vect (nindex + ncons + 1) nparam in 146 | (* Construct a motive term wrapping that bound in `context`. *) 147 | let motive = eta_guard_motive ncons nindex motive_type in 148 | (* Collect the `ncons` constructor recurrences bound in `context`. *) 149 | let recurs = Termops.rel_vect nindex ncons in 150 | (* Assemble the `nindex` indices bound in `context`, each eta-expanded if sigma type. *) 151 | let indices = eta_expand_indices index_ctxt |> Array.rev_of_list in 152 | Array.concat [params; [|motive|]; recurs; indices] 153 | in 154 | (* Close the wrapped eliminator term and type over the `context` of quantifiers. *) 155 | Term.compose_lam context (mkApp (elim_term, arguments)), 156 | Term.compose_prod context typ 157 | -------------------------------------------------------------------------------- /plugin/src/automation/depelim.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Dependent elimination for inductive families over sigma-packed indices. 3 | *) 4 | 5 | open Constr 6 | open Inductive 7 | 8 | (* 9 | * Construct a wrapper term around an inductive family's (given as a 10 | * `mind_specif`) eliminator (given as a constant `constr` reference with its 11 | * `types`), returning both the wrapper `constr` and its "natural" `types`. 12 | * 13 | * The wrapper term resembles an eta-expansion of the underlying eliminator, 14 | * except that the applied motive is also an eta-expansion in which any index 15 | * of sigma type is definitionally eta-expanded. The net effect is that the 16 | * wrapped eliminator accepts a motive expecting definitional eta-expansion 17 | * of indices with sigma type. 18 | * 19 | * The wrapped eliminator can be understood as enabling implicit dependent 20 | * elimination for the inductive family w.r.t. its indices of sigma type. 21 | * Since the canonical form of a sigma type is irrefutable, this (fairly) 22 | * simple instance of dependent elimination does not need to rely on any 23 | * extra axiom or any special (proof of a) property like UIP. 24 | * 25 | * NOTE: Using the returned `types` is not strictly necessary, but it is much 26 | * more readable than that inferred by type-checking. 27 | *) 28 | val eta_guard_eliminator : mind_specif -> constr -> types -> constr * types 29 | -------------------------------------------------------------------------------- /plugin/src/automation/lift/lift.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Core lifting algorithm 3 | *) 4 | 5 | open Names 6 | open Constr 7 | open Environ 8 | open Evd 9 | open Lifting 10 | open Stateutils 11 | 12 | (* 13 | * Lift a constant along an ornament 14 | *) 15 | val do_lift_defn : 16 | env -> 17 | evar_map -> 18 | lifting -> (* lifting configuration *) 19 | constr -> (* unlifted constant (defined function) *) 20 | constr list -> (* constants to treat as opaque *) 21 | types state (* lifted function *) 22 | 23 | val do_lift_ind : 24 | env -> 25 | evar_map -> 26 | lifting -> (* lifting configuration *) 27 | Id.t -> 28 | string -> 29 | inductive -> 30 | constr list -> (* constants to treat as opaque *) 31 | bool -> (* whether we're lifting a whole module *) 32 | inductive (* lifted type and number of constructors for caching *) 33 | -------------------------------------------------------------------------------- /plugin/src/automation/lift/liftconfig.mli: -------------------------------------------------------------------------------- 1 | open Lifting 2 | open Constr 3 | open Environ 4 | open Evd 5 | open Stateutils 6 | open Reducers 7 | 8 | (* 9 | * Lifting configuration: Includes the lifting, types, and cached rules 10 | * for optimizations, as well as interfaces to ask questions about 11 | * the configuration and some initialization code. 12 | * 13 | * This is where lifting constructors and projections live, since those 14 | * are configured ahead of time. Eventually, the bulk of lifting eliminators 15 | * may live here as well. 16 | *) 17 | 18 | (* --- Datatype --- *) 19 | 20 | type lift_config 21 | 22 | (* --- Initialization --- *) 23 | 24 | val initialize_lift_config : 25 | env -> 26 | lifting -> 27 | constr list -> (* opaques *) 28 | evar_map -> 29 | lift_config state 30 | 31 | (* --- Recover or set the lifting --- *) 32 | 33 | val get_lifting : lift_config -> lifting 34 | 35 | (* --- Caching --- *) 36 | 37 | (* 38 | * Check opaqueness using either local or global cache 39 | *) 40 | val is_opaque : lift_config -> constr -> bool 41 | 42 | (* 43 | * Configurable caching of constants 44 | *) 45 | val smart_cache : lift_config -> constr -> constr -> unit 46 | 47 | (* 48 | * Check if something is in the local cache 49 | *) 50 | val is_cached : lift_config -> constr -> bool 51 | 52 | (* 53 | * Lookup something from the local cache 54 | *) 55 | val lookup_cache : lift_config -> constr -> constr 56 | 57 | (* --- Questions about types A and B --- *) 58 | 59 | val get_types : lift_config -> types * types 60 | 61 | (* 62 | * Determine if the supplied type is the type we are lifting from 63 | * Return the arguments if true 64 | *) 65 | val is_from : 66 | lift_config -> env -> types -> evar_map -> ((constr list) option) state 67 | 68 | (* 69 | * Like is_from, but just assume it's the right type and get the arguments 70 | *) 71 | val from_args : 72 | lift_config -> env -> types -> evar_map -> (constr list) state 73 | 74 | (* 75 | * Like is_from, but taking a term and checking on its type 76 | *) 77 | val type_is_from : 78 | lift_config -> env -> constr -> evar_map -> ((constr list) option) state 79 | 80 | (* 81 | * Like type_is_from, but just assume it's the right type and get the arguments 82 | *) 83 | val type_from_args : 84 | lift_config -> env -> constr -> evar_map -> (constr list) state 85 | 86 | (* --- Eta, iota, and coherence (for preserving definitional equalities) --- *) 87 | 88 | (* 89 | * Get the cached lifted eta expansion function 90 | *) 91 | val get_lifted_eta : lift_config -> constr 92 | 93 | (* 94 | * Check if a term applies some projection 95 | *) 96 | val is_proj : 97 | lift_config -> 98 | env -> 99 | constr -> 100 | evar_map -> 101 | (* proj, args, trm_eta *) 102 | ((constr * constr list * constr) option) state 103 | 104 | (* 105 | * Check if a term may apply the eta expansion function, 106 | * but don't bother checking the type 107 | *) 108 | val may_apply_eta : lift_config -> env -> constr -> bool 109 | 110 | (* 111 | * Check if the term applies the eta expansion identity function 112 | * If so, return the the arguments 113 | *) 114 | val applies_eta : 115 | lift_config -> 116 | env -> 117 | constr -> 118 | evar_map -> 119 | ((constr list) option) state 120 | 121 | (* 122 | * Iota rules 123 | *) 124 | val get_iota : lift_config -> constr array 125 | val get_lifted_iota : lift_config -> constr array 126 | 127 | (* 128 | * Check if the term applies Iota 129 | * If so, return the the arguments 130 | *) 131 | val applies_iota : 132 | lift_config -> 133 | env -> 134 | constr -> 135 | evar_map -> 136 | ((int * constr list) option) state 137 | 138 | (* --- Constructors and eliminators --- *) 139 | 140 | (* 141 | * Get DepConstr 142 | *) 143 | val get_constrs : lift_config -> constr array 144 | val get_lifted_constrs : lift_config -> constr array 145 | 146 | (* 147 | * Get DepElim 148 | *) 149 | val get_dep_elim : lift_config -> types 150 | val get_lifted_dep_elim : lift_config -> types 151 | 152 | (* 153 | * Check if the term applies the eta expansion function 154 | * If so, return the the constructor index, arguments, and whether to treat 155 | * the constructor as opaque when lifting recursively 156 | *) 157 | val applies_constr_eta : 158 | lift_config -> 159 | env -> 160 | constr -> 161 | evar_map -> 162 | ((int * (constr list)) option) state 163 | 164 | (* 165 | * Check if the term applies DepElim 166 | * If so return the eta-expanded term and the arguments 167 | *) 168 | val applies_elim : 169 | lift_config -> 170 | env -> 171 | constr -> 172 | evar_map -> 173 | ((constr option * (constr list)) option) state 174 | 175 | (* --- Custom simplification --- *) 176 | 177 | (* 178 | * Custom reduction functions for lifted eta and coherence, 179 | * for efficiency and to ensure termination. For example, this may 180 | * simplify projections of existentials. 181 | *) 182 | val reduce_lifted_eta : lift_config -> reducer 183 | val reduce_coh : lift_config -> reducer 184 | val reduce_constr_app : lift_config -> reducer 185 | val reduce_lifted_elim : lift_config -> reducer 186 | 187 | (* 188 | * Determine if we can be smarter than Coq and simplify earlier 189 | * If yes, return how 190 | * Otherwise, return None 191 | *) 192 | val can_reduce_now : lift_config -> env -> constr -> reducer option 193 | 194 | (* --- Modifying the configuration --- *) 195 | 196 | val reverse : lift_config -> lift_config 197 | val zoom : lift_config -> lift_config 198 | -------------------------------------------------------------------------------- /plugin/src/automation/lift/liftrules.mli: -------------------------------------------------------------------------------- 1 | open Liftconfig 2 | open Constr 3 | open Environ 4 | open Evd 5 | open Stateutils 6 | open Reducers 7 | 8 | (* 9 | * This module takes in a Coq term that we are lifting and determines 10 | * the appropriate lifting rule to run 11 | *) 12 | 13 | (* --- Datatypes --- *) 14 | 15 | (* 16 | * When an optimization may be possible, we return one of these. 17 | * Sometimes, we need more information to determine if the optimization is 18 | * definitely possible. This just makes it very explicit in the code what 19 | * is an attempt at an optimization, as opposed to what is needed for 20 | * correctness only. 21 | * 22 | * See the implementation for an explanation of each of these. 23 | *) 24 | type lift_optimization = 25 | | GlobalCaching of constr 26 | | LocalCaching of constr 27 | | OpaqueConstant 28 | | SimplifyProjectId of reducer * (constr * constr array) 29 | | LazyEta of constr 30 | | AppLazyDelta of constr * constr array 31 | | ConstLazyDelta of Names.Constant.t Univ.puniverses 32 | 33 | (* 34 | * We compile Gallina to a language that matches our premises for the rules 35 | * in our lifting algorithm. Each of these rules carries more information 36 | * that is essentially cached for efficiency. 37 | * 38 | * See the implementation for an explanation of each of these. 39 | *) 40 | type lift_rule = 41 | | Equivalence of constr * constr list 42 | | LiftConstr of reducer * (constr * constr list) 43 | | Eta of reducer * (constr * constr list) 44 | | Iota of constr * constr list 45 | | Coherence of reducer * (constr * constr list) 46 | | Optimization of lift_optimization 47 | | CIC of (constr, types, Sorts.t, Univ.Instance.t) kind_of_term 48 | 49 | (* 50 | * Determine which lift rule to run 51 | * 52 | * The lift_rule argument is the previous lift rules 53 | * to prevent infinite recursion in obvious cases 54 | *) 55 | val determine_lift_rule : 56 | lift_config -> env -> constr -> lift_rule list -> evar_map -> lift_rule state 57 | -------------------------------------------------------------------------------- /plugin/src/automation/search/coherence.ml: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Utilities 3 | open Zooming 4 | open Promotion 5 | open Typehofs 6 | open Envutils 7 | open Apputils 8 | open Equtils 9 | open Sigmautils 10 | open Ornerrors 11 | 12 | (* --- Automatically generated coherence proof --- *) 13 | 14 | (* 15 | * Prove coherence with the components search finds 16 | * Return the coherence proof term and its type 17 | *) 18 | let prove_coherence env sigma orn = 19 | match orn.kind with 20 | | Algebraic (indexer, off) -> 21 | let promote = lookup_definition env orn.promote in 22 | let env_coh = zoom_env zoom_lambda_term env promote in 23 | let a = mkRel 1 in 24 | let is = on_red_type_default (ignore_env unfold_args) env_coh sigma a in 25 | let b_sig = mkAppl (orn.promote, snoc a is) in 26 | let b_sig_typ = on_red_type_default (ignore_env dest_sigT) env_coh sigma b_sig in 27 | let ib = mkAppl (indexer, snoc a is) in 28 | let ib_typ = b_sig_typ.index_type in 29 | let proj_ib = project_index b_sig_typ b_sig in 30 | let refl = apply_eq_refl { typ = ib_typ; trm = proj_ib } in 31 | let refl_typ = apply_eq { at_type = ib_typ; trm1 = proj_ib; trm2 = ib } in 32 | let coh = reconstruct_lambda env_coh refl in 33 | let coh_typ = reconstruct_product env_coh refl_typ in 34 | (coh, coh_typ) 35 | | _ -> 36 | raise NotAlgebraic 37 | -------------------------------------------------------------------------------- /plugin/src/automation/search/coherence.mli: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Environ 3 | open Promotion 4 | open Evd 5 | 6 | (* --- Automatically generated coherence proof --- *) 7 | 8 | (* 9 | * Prove coherence with the components search finds 10 | * Return the coherence proof term and its type 11 | * (The type is nicer than the one Coq infers) 12 | *) 13 | val prove_coherence : env -> evar_map -> promotion -> (types * types) 14 | -------------------------------------------------------------------------------- /plugin/src/automation/search/equivalence.mli: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Names 3 | open Environ 4 | open Evd 5 | open Lifting 6 | open Stateutils 7 | 8 | (* --- Automatically generated equivalence proofs about search components --- *) 9 | 10 | (* 11 | * Prove section and retraction 12 | * Return the section term and the retraction term, as well as their types 13 | *) 14 | val prove_equivalence : 15 | env -> evar_map -> lifting -> ((constr * types) * (constr * types)) 16 | 17 | type pre_adjoint = { 18 | orn : lifting; 19 | sect : Constant.t; 20 | retr0 : Constant.t 21 | } 22 | 23 | (* 24 | * Augment the initial retraction proof in order to prove adjunction. 25 | * 26 | * The generic proof of adjunction from the HoTT book relies critically on this 27 | * step; wrapping the proof term for retraction in a clever way (formalized in 28 | * `fg_id'`) makes a later equality of equality proofs true definitionally. 29 | *) 30 | val adjointify_retraction : 31 | env -> pre_adjoint -> evar_map -> constr state 32 | 33 | (* 34 | * Prove adjunction. 35 | *) 36 | val prove_adjunction : 37 | env -> pre_adjoint -> evar_map -> (constr * types) state 38 | -------------------------------------------------------------------------------- /plugin/src/automation/search/search.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Searching for ornamental promotions between inductive types 3 | *) 4 | 5 | open Constr 6 | open Environ 7 | open Evd 8 | open Names 9 | open Promotion 10 | open Stateutils 11 | 12 | (* --- Top-level search --- *) 13 | 14 | (* 15 | * Search for an ornamental promotion between two types 16 | *) 17 | val search_orn : 18 | env -> 19 | evar_map -> 20 | Id.t option -> (* name to assign the indexer function, if relevant *) 21 | int option -> (* offset of swap map, if relevant *) 22 | types -> (* old type *) 23 | types -> (* new type *) 24 | promotion state (* ornamental promotion *) 25 | 26 | (* 27 | * Try to invert a single component of an ornamental promotion isomorphism 28 | * (Like search, but only in one direction) 29 | * 30 | * Exactly one of promote and forget must be present, otherwise this fails 31 | *) 32 | val invert_orn : 33 | env -> 34 | evar_map -> 35 | Id.t option -> (* name to assign the indexer function, if relevant *) 36 | int option -> (* offset of swap map, if relevant *) 37 | types -> (* old type *) 38 | types -> (* new type *) 39 | constr option -> (* optional promotion function *) 40 | constr option -> (* optional forgetful function *) 41 | promotion state (* ornamental promotion *) 42 | -------------------------------------------------------------------------------- /plugin/src/automation/search/smartelim.ml: -------------------------------------------------------------------------------- 1 | open Lifting 2 | open Promotion 3 | open Libnames 4 | open Constr 5 | open Nametab 6 | open Apputils 7 | open Reducers 8 | open Zooming 9 | open Environ 10 | open Envutils 11 | open Debruijn 12 | open Idutils 13 | open Sigmautils 14 | open Names 15 | open Utilities 16 | open Equtils 17 | open Nameutils 18 | 19 | (* 20 | * If the appropriate option is set, DEVOID generates useful "smart eliminators" 21 | * in addition to the equivalences it discovers. For example, for algebraic 22 | * ornaments, it generates and automatically lifts a useful eliminator over 23 | * { a : A & indexer a = i_b } that helps the user combine proofs about A and 24 | * proofs about the index of a, so that later the user can get proofs about 25 | * unpacked B. 26 | *) 27 | 28 | (* --- Constants --- *) 29 | 30 | let packed_rect () = 31 | let n = qualid_of_string "Ornamental.Eliminators.packed_rect" in 32 | mkConst (locate_constant n) 33 | 34 | (* --- Procedure --- *) 35 | 36 | (* 37 | * Generate the list of smart eliminators 38 | *) 39 | let find_smart_elims l env sigma = 40 | match l.orn.kind with 41 | | Algebraic (indexer, _) -> 42 | (* Eliminate { a : A & indexer a = i_b } *) 43 | let promote = lift_to l in 44 | let sigma, elim = 45 | let sigma, promote_typ = reduce_type env sigma promote in 46 | let env_a, b_typ = zoom_product_type env promote_typ in 47 | let sigma, a_typ = reduce_type env_a sigma (mkRel 1) in 48 | let env_args = pop_rel_context 1 env_a in 49 | let body = 50 | let f = packed_rect () in 51 | let args = 52 | let (a_typ, b_typ) = map_tuple unshift (a_typ, b_typ) in 53 | let i_b_typ = (dest_sigT b_typ).index_type in 54 | let a_args = unfold_args a_typ in 55 | let indexer_app = mkAppl (indexer, a_args) in 56 | let id_app = mkAppl (id_typ, [a_typ]) in 57 | let coh_app = 58 | let push typ = push_local (Anonymous, typ) in 59 | let env_coh = push (shift a_typ) (push i_b_typ env_args) in 60 | let eq = 61 | let a_args = shift_all_by 2 a_args in 62 | let at_type = shift_by 2 i_b_typ in 63 | let trm1 = mkAppl (indexer, snoc (mkRel 1) a_args) in 64 | let trm2 = mkRel 2 in 65 | apply_eq { at_type; trm1; trm2 } 66 | in 67 | let body_coh = mkAppl (id_typ, [eq]) in 68 | reconstruct_lambda_n env_coh body_coh (nb_rel env_args) 69 | in [a_typ; i_b_typ; indexer_app; id_app; coh_app] 70 | in mkAppl (f, args) 71 | in sigma, reconstruct_lambda env_args body 72 | in 73 | let sigma, t = chain_reduce reduce_type remove_identities env sigma elim in 74 | sigma, [(suffix_term_name promote (Id.of_string "_rect"), elim, t)] 75 | | _ -> 76 | sigma, [] 77 | -------------------------------------------------------------------------------- /plugin/src/automation/search/smartelim.mli: -------------------------------------------------------------------------------- 1 | open Environ 2 | open Evd 3 | open Constr 4 | open Stateutils 5 | open Lifting 6 | open Names 7 | 8 | (* 9 | * If the appropriate option is set, DEVOID generates useful "smart eliminators" 10 | * in addition to the equivalences it discovers. For example, for algebraic 11 | * ornaments, it generates and automatically lifts a useful eliminator over 12 | * { a : A & indexer a = i_b } that helps the user combine proofs about A and 13 | * proofs about the index of a, so that later the user can get proofs about 14 | * unpacked B after lifting. 15 | *) 16 | 17 | (* 18 | * Generate the list of smart eliminators 19 | *) 20 | val find_smart_elims : 21 | lifting -> env -> evar_map -> ((Id.t * constr * types) list) state 22 | -------------------------------------------------------------------------------- /plugin/src/automation/unpack.ml: -------------------------------------------------------------------------------- 1 | open Util 2 | open Libnames 3 | open Ltac_plugin 4 | 5 | let tactic_script = 6 | qualid_of_string "Ornamental.Unpack.unpack" 7 | 8 | (* Evaluate a tactic on no goals and return any proofs constructed *) 9 | let eval_tactic env sigma ?goal tac = 10 | let typ, _ = Evarutil.e_new_type_evar env sigma Evd.univ_flexible_alg in 11 | let (ent, pv) = Proofview.init !sigma [(env, typ)] in 12 | let sigma0 = !sigma in 13 | let ((), pv, (unsafe, shelved, obliged), _) = Proofview.apply env tac pv in 14 | sigma := Proofview.proofview pv |> snd; 15 | (* NOTE: Technically our current examples/tests do not require this post-processing 16 | * unification step, but I suspect that it may sometimes be necessary to ensure that 17 | * Coq handles any lingering typeclass/implicit argument inference in the usual way. *) 18 | sigma := Pretyping.solve_remaining_evars (Pretyping.default_inference_flags true) env !sigma sigma0; 19 | let proofs = Proofview.partial_proof ent pv |> List.map (EConstr.to_constr !sigma) in 20 | List.hd proofs 21 | 22 | let call_tactic env sigma tac args = 23 | let open Tacexpr in 24 | let args = List.map (fun e -> ConstrMayEval (Genredexpr.ConstrTerm e)) args in 25 | TacArg (Loc.tag (TacCall (Loc.tag (tac, args)))) |> Tacinterp.interp |> 26 | eval_tactic env sigma 27 | 28 | let unpack_constant env sigma const = 29 | let term = Evarutil.e_new_global sigma (Names.GlobRef.ConstRef const) in 30 | call_tactic env sigma tactic_script [Constrextern.extern_constr false env !sigma term] 31 | -------------------------------------------------------------------------------- /plugin/src/automation/unpack.mli: -------------------------------------------------------------------------------- 1 | open Names 2 | open Constr 3 | 4 | val unpack_constant : Environ.env -> Evd.evar_map ref -> Constant.t -> constr 5 | -------------------------------------------------------------------------------- /plugin/src/cache/caching.mli: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Promotion 3 | 4 | (* --- Database for higher lifting --- *) 5 | 6 | (* 7 | * Lookup a lifting along an ornament 8 | * Arguments: lift_to, lift_back, trm 9 | * 10 | * Return None if the lifting does not exist or is not in the current environment 11 | *) 12 | val lookup_lifting : (constr * constr * constr) -> constr option 13 | 14 | (* 15 | * Store a lifting along an ornament 16 | * Order of arguments: lift_to, lift_back, trm, lifted_trm 17 | *) 18 | val save_lifting : (constr * constr * constr) -> constr -> unit 19 | 20 | (* --- Database for global opaque liftings --- *) 21 | 22 | (* 23 | * Lookup if a lifting is globally opaque 24 | * Arguments: lift_to, lift_back, trm 25 | *) 26 | val lookup_opaque : (constr * constr * constr) -> bool 27 | 28 | (* 29 | * Store an opaque lifting 30 | * Also saves it as a lifting 31 | * Order of arguments: lift_to, lift_back, trm 32 | *) 33 | val save_opaque : (constr * constr * constr) -> unit 34 | 35 | (* 36 | * Remove an opaque lifting 37 | * Also removes it from liftings 38 | * Order of arguments: lift_to, lift_back, trm 39 | *) 40 | val remove_opaque : (constr * constr * constr) -> unit 41 | 42 | (* --- Temporary cache of constants --- *) 43 | 44 | type temporary_cache 45 | 46 | (* 47 | * Initialize the local cache 48 | *) 49 | val initialize_local_cache : unit -> temporary_cache 50 | 51 | (* 52 | * Check whether a constant is in the local cache 53 | *) 54 | val is_locally_cached : temporary_cache -> types -> bool 55 | 56 | (* 57 | * Lookup a value in the local cache 58 | *) 59 | val lookup_local_cache : temporary_cache -> types -> types 60 | 61 | (* 62 | * Add a value to the local cache 63 | *) 64 | val cache_local : temporary_cache -> types -> types -> unit 65 | 66 | (* --- Database of ornaments --- *) 67 | 68 | (* 69 | * Lookup an ornament between two types 70 | * Arguments: typ1, typ2 71 | * Order of return values: typ1_to_typ2, typ2_to_typ1, kind of ornament 72 | * 73 | * Return None if the ornament does not exist or is not in the current 74 | * environment 75 | *) 76 | val lookup_ornament : 77 | (types * types) -> (constr * constr * kind_of_orn) option 78 | 79 | (* 80 | * Store an ornament between two types, given the function and its inverse 81 | * Order of arguments: typ1, typ2, typ1_to_typ2, typ2_to_typ1 82 | *) 83 | val save_ornament : 84 | (types * types) -> (constr * constr * kind_of_orn) -> unit 85 | 86 | (* --- Database of configuration --- *) 87 | 88 | (* 89 | * Lookup DepConstr, DepElim, Eta, and Iota 90 | * Arguments: orn_o, orn_n 91 | * Order of return values: dep_constrs, dep_elims, etas, iotas 92 | * (for now, just two of these, since this is work in progress) 93 | * 94 | * Return None if the configuration does not exist or is not in the current 95 | * environment 96 | *) 97 | val lookup_config : 98 | (types * types) -> 99 | ((constr array * constr array) * 100 | (constr * constr) * 101 | (constr * constr) * 102 | (constr array * constr array)) option 103 | 104 | (* 105 | * Store DepConstr, DepElim, Eta, and Iota 106 | *) 107 | val save_dep_constrs : (types * types) -> (constr array * constr array) -> unit 108 | val save_dep_elim : (types * types) -> (constr * constr) -> unit 109 | val save_eta : (types * types) -> (constr * constr) -> unit 110 | val save_iota : (types * types) -> (constr array * constr array) -> unit 111 | -------------------------------------------------------------------------------- /plugin/src/components/abstraction.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Abstraction specific to ornamental search 3 | *) 4 | 5 | open Constr 6 | open Debruijn 7 | open Indexing 8 | open Names 9 | open Apputils 10 | open Reducers 11 | 12 | (* 13 | * Given an application and the index of the argument, abstract by the argument 14 | *) 15 | let abstract_arg env sigma i typ = 16 | let arg = get_arg i typ in 17 | let sigma, arg_typ = reduce_type env sigma arg in 18 | let args = reindex i (mkRel 1) (shift_all (unfold_args typ)) in 19 | sigma, mkLambda (Anonymous, arg_typ, mkAppl (first_fun typ, args)) 20 | 21 | (* Replace all occurrences of the first term in the second term with Rel 1, 22 | * lifting de Bruijn indices as needed. The notion of term equality is modulo 23 | * alpha, casts, application grouping, and universes. 24 | *) 25 | let abstract_subterm sub term = 26 | let rec surgery (nb, sub) term = 27 | match eq_constr_head sub term with 28 | | Some args -> 29 | mkApp (mkRel (nb + 1), args) 30 | | None -> 31 | Constr.map_with_binders 32 | (fun (nb, sub) -> nb + 1, shift sub) 33 | surgery 34 | (nb, sub) 35 | term 36 | in surgery (0, shift sub) (shift term) 37 | -------------------------------------------------------------------------------- /plugin/src/components/abstraction.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Abstraction specific to ornamental search 3 | *) 4 | 5 | open Constr 6 | open Environ 7 | open Evd 8 | open Stateutils 9 | 10 | (* 11 | * Given an application and the index of the argument, abstract by the argument 12 | *) 13 | val abstract_arg : env -> evar_map -> int -> types -> types state 14 | 15 | (* Replace all occurrences of the first term in the second term with Rel 1, 16 | * lifting de Bruijn indices as needed. The notion of term equality is modulo 17 | * alpha, casts, application grouping, and universes. 18 | *) 19 | val abstract_subterm : constr -> constr -> constr 20 | -------------------------------------------------------------------------------- /plugin/src/components/differencing.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Differencing component 3 | *) 4 | 5 | open Constr 6 | open Environ 7 | open Utilities 8 | open Debruijn 9 | open Context 10 | open Util 11 | open Convertibility 12 | open Inference 13 | open Apputils 14 | open Envutils 15 | open Stateutils 16 | 17 | (* --- Differencing terms --- *) 18 | 19 | (* Check if two terms have the same type *) 20 | let same_type env sigma o n = 21 | let (env_o, t_o) = o in 22 | let (env_n, t_n) = n in 23 | let sigma, typ_o = infer_type env_o sigma t_o in 24 | let sigma, typ_n = infer_type env_o sigma t_n in 25 | convertible env sigma typ_o typ_n 26 | 27 | (* --- Differencing inductive types --- *) 28 | 29 | (* is_or_applies over two terms with a different check *) 30 | let apply_old_new (o : types * types) (n : types * types) : bool = 31 | let (trm_o, trm_o') = o in 32 | let (trm_n, trm_n') = n in 33 | is_or_applies trm_o trm_o' && is_or_applies trm_n trm_n' 34 | 35 | (* Check if two terms are the same modulo a change of an inductive type *) 36 | let same_mod_change env sigma o n = 37 | let (t_o, t_n) = map_tuple snd (o, n) in 38 | if apply_old_new o n then 39 | sigma, true 40 | else 41 | convertible env sigma t_o t_n 42 | 43 | (* Check if two terms are the same modulo an indexing of an inductive type *) 44 | let same_mod_indexing env sigma p_index o n = 45 | let (t_o, t_n) = map_tuple snd (o, n) in 46 | if are_or_apply p_index t_o t_n then 47 | sigma, true 48 | else 49 | same_mod_change env sigma o n 50 | 51 | (* --- Finding the New Index --- *) 52 | 53 | (* 54 | * This determines IB and off 55 | *) 56 | 57 | (* 58 | * Compute the difference between the applications of motives in the IHs 59 | * of eliminator types trm_o and trm_n, assuming there is some new index 60 | * in the type trm_n eliminates over that is not in trm_o. 61 | * 62 | * Return a list of offsets paired with pairs of old and new 63 | * indices. 64 | *) 65 | let diff_motive_apps trm_o trm_n = 66 | let rec diff off p trm_o trm_n = 67 | match map_tuple kind (trm_o, trm_n) with 68 | | (Prod (n_o, t_o, b_o), Prod (n_n, t_n, b_n)) -> 69 | if applies p t_o && not (applies p t_n) then 70 | diff (shift_i off) (shift p) (shift trm_o) b_n 71 | else 72 | List.append (diff off p t_o t_n) (diff off (shift p) b_o b_n) 73 | | (App (_, _), App (_, _)) when applies p trm_o && applies p trm_n -> 74 | let args_o = all_but_last (unfold_args trm_o) in 75 | let args_n = all_but_last (unfold_args trm_n) in 76 | [(off, (mkAppl (p, args_o), mkAppl (p, args_n)))] 77 | | _ -> 78 | [] 79 | in List.rev (diff 0 (mkRel 1) trm_o trm_n) 80 | 81 | (* 82 | * Returns true if the argument at the supplied index location of the 83 | * inductive motive (which should be at relative index 1 before calling 84 | * this function) is an index to some application of the induction principle 85 | * in the second term that was not an index to any application of the induction 86 | * principle in the first term. 87 | * 88 | * In other words, this looks for applications of the motive 89 | * in the induction principle type, checks the argument at the location, 90 | * and determines whether they were equal. If they are ever not equal, 91 | * then the index is considered to be new. Since we are ornamenting, 92 | * we can assume that we maintain the same inductive structure, and so 93 | * we should encounter applications of the induction principle in both 94 | * terms in exactly the same order. 95 | * 96 | * The implementation of this uses an offset list to adjust as it goes. 97 | *) 98 | let is_new_index i b_o b_n = 99 | let d = diff_motive_apps b_o b_n in 100 | try 101 | let arg args = get_arg i args in 102 | let d_arg = List.map (fun (off, (o, n)) -> (off, (arg o, arg n))) d in 103 | let rec is_new d = 104 | match d with 105 | | (off, (o, n)) :: tl -> 106 | if equal o n then 107 | is_new tl 108 | else 109 | if off > 0 then 110 | is_new (List.map (fun (off, (o, n)) -> (off - 1, (o, shift n))) d) 111 | else 112 | true 113 | | [] -> 114 | false 115 | in is_new d_arg 116 | with Invalid_argument s -> 117 | true (* we're on the last index *) 118 | 119 | (* 120 | * Assuming there is an indexing ornamental relationship between two 121 | * eliminators, get the type and location of the new index. 122 | * This starts by identifying candidate new indices, then filters 123 | * them to the ones that are truly different. 124 | * 125 | * If indices depend on earlier types, the types may be dependent; 126 | * the client needs to shift by the appropriate offset. 127 | * 128 | * This algorithm only runs when there is ambiguity, since Nate's 129 | * algorithm can take care of simpler cases where the types enough 130 | * are revealing. There are some examples of ambiguity in Test.v; 131 | * these should never break, and if they do, it means the code is incorrect. 132 | *) 133 | let new_index_type env sigma elim_t_o elim_t_n = 134 | let (_, p_o, b_o) = destProd elim_t_o in 135 | let (_, p_n, b_n) = destProd elim_t_n in 136 | let rec candidates e sigma p_o p_n = 137 | match map_tuple kind (p_o, p_n) with 138 | | (Prod (n_o, t_o, b_o), Prod (_, t_n, b_n)) -> 139 | if isProd b_o then 140 | branch_state 141 | (fun (t_o, t_n) sigma -> convertible e sigma t_o t_n) 142 | (fun (t_o, t_n) sigma -> 143 | let e_b = push_local (n_o, t_o) e in 144 | let sigma, same = candidates e_b sigma b_o b_n in 145 | let diff = (0, t_n) in 146 | sigma, diff :: (List.map (fun (i, i_t) -> (shift_i i, i_t)) same)) 147 | (fun (t_o, t_n) sigma -> sigma, [(0, t_n)]) 148 | (t_o, t_n) 149 | sigma 150 | else 151 | sigma, [(0, t_n)] 152 | | _ -> 153 | failwith "could not find indexer motive" 154 | in 155 | Util.on_snd 156 | (List.find (fun (i, _) -> is_new_index i b_o b_n)) 157 | (candidates env sigma p_o p_n) 158 | 159 | (* 160 | * This is Nate's simple search heuristic that works when there is no ambiguity 161 | *) 162 | let diff_context_simple env sigma decls_o decls_n = 163 | let nth_type n = Rel.Declaration.get_type (List.nth decls_n n) in 164 | let rec scan env pos diff (decls_o, decls_n) sigma : (int option) state = 165 | match (decls_o, decls_n) with 166 | | (decl_o :: decls_o_b), (decl_n :: decls_n_b) -> 167 | let type_o = Rel.Declaration.get_type decl_o in 168 | let type_n = Rel.Declaration.get_type decl_n in 169 | let env_b = push_rel decl_n env in 170 | let pos_b = pos + 1 in 171 | branch_state 172 | (fun (type_o, type_n) sigma -> convertible env sigma type_o type_n) 173 | (fun (type_o, type_n) sigma -> 174 | let sigma_b, diff_b = scan env_b pos_b diff (decls_o_b, decls_n_b) sigma in 175 | if Option.has_some diff_b && Option.get diff_b = pos_b then 176 | let type_i = nth_type pos_b in 177 | branch_state 178 | (not_state 179 | (fun (type_o, type_i) sigma_b -> 180 | convertible env_b sigma_b (shift type_o) type_i)) 181 | (fun _ -> ret diff_b) 182 | (fun _ -> ret None) (* ambiguous, can't use this heuristic *) 183 | (type_o, type_i) 184 | sigma_b 185 | else 186 | sigma, diff_b) 187 | (fun _ -> scan env_b pos_b (Some pos) (decls_o, decls_n_b)) 188 | (type_o, type_n) 189 | sigma 190 | | [], (decl_n :: decls_n_b) -> 191 | if List.length decls_n_b > 0 then 192 | failwith "Please add just one new index at a time." 193 | else 194 | sigma, Some pos (* the last index is new *) 195 | | _ -> 196 | failwith "No new indices. Try switching directions." 197 | in 198 | let sigma, diff_pos = scan env 0 None (decls_o, decls_n) sigma in 199 | if Option.has_some diff_pos then 200 | let pos = Option.get diff_pos in 201 | let typ = nth_type pos in 202 | Some (sigma, (pos, typ)) 203 | else 204 | None 205 | 206 | (* 207 | * Top-level index finder for Nate's heuristic 208 | *) 209 | let new_index_type_simple env sigma ind_o ind_n = 210 | (* Applying each parameter increments the index for the next one. *) 211 | let npars = nb_rel env in 212 | let pars = List.make npars (mkRel npars) in 213 | let pind_o = Univ.in_punivs ind_o in 214 | let pind_n = Univ.in_punivs ind_n in 215 | let indf_o = Inductiveops.make_ind_family (pind_o, pars) in 216 | let indf_n = Inductiveops.make_ind_family (pind_n, pars) in 217 | let (idcs_o, _) = Inductiveops.get_arity env indf_o in 218 | let (idcs_n, _) = Inductiveops.get_arity env indf_n in 219 | diff_context_simple env sigma (List.rev idcs_o) (List.rev idcs_n) 220 | 221 | 222 | 223 | -------------------------------------------------------------------------------- /plugin/src/components/differencing.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Differencing component 3 | *) 4 | 5 | open Constr 6 | open Environ 7 | open Evd 8 | open Names 9 | open Stateutils 10 | 11 | (* --- Differencing terms --- *) 12 | 13 | (* Check if two terms have the same type under some set of constraints *) 14 | val same_type : 15 | env -> evar_map -> (env * types) -> (env * types) -> bool state 16 | 17 | (* --- Differencing inductive types --- *) 18 | 19 | (* Check if two terms are the same modulo an indexing of an inductive type *) 20 | val same_mod_indexing : 21 | env -> evar_map -> types -> (types * types) -> (types * types) -> bool state 22 | 23 | (* --- Differencing for new indices --- *) 24 | 25 | (* 26 | * Given an environment and two eliminators, find the new index location 27 | * and type using the algorithm that handles ambiguity. 28 | * Leave offsets to the client. 29 | *) 30 | val new_index_type : env -> evar_map -> types -> types -> (int * types) state 31 | 32 | (* 33 | * Given an environment and two inductive types, 34 | * find the new index location and type using the simple heuristic that 35 | * doesn't handle ambiguity. 36 | * Leave offsets to the client. 37 | *) 38 | val new_index_type_simple : env -> evar_map -> inductive -> inductive -> ((int * types) state) option 39 | 40 | -------------------------------------------------------------------------------- /plugin/src/components/factoring.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Factoring 3 | *) 4 | 5 | open Constr 6 | open Debruijn 7 | 8 | (* --- Type-level factoring --- *) 9 | 10 | (* Deconstruct a product type (A -> B -> ... -> D) into A, B, ..., D *) 11 | let rec factor_product (trm : types) : types list = 12 | match kind trm with 13 | | Prod (n, t, b) -> 14 | t :: factor_product (unshift b) 15 | | _ -> 16 | [] 17 | -------------------------------------------------------------------------------- /plugin/src/components/factoring.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Factoring 3 | *) 4 | 5 | open Constr 6 | 7 | (* --- Type-level factoring --- *) 8 | 9 | val factor_product : types -> types list 10 | -------------------------------------------------------------------------------- /plugin/src/components/specialization.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * Specialization component 3 | *) 4 | 5 | open Lifting 6 | open Hofs 7 | open Substitution 8 | open Utilities 9 | open Indexing 10 | open Abstraction 11 | open Constr 12 | open Inference 13 | open Typehofs 14 | open Reducers 15 | open Apputils 16 | open Sigmautils 17 | open Envutils 18 | open Stateutils 19 | open Desugarprod 20 | open Promotion 21 | open Evarutil 22 | open Evarconv 23 | open Zooming 24 | open Equtils 25 | 26 | (* --- Specialization --- *) 27 | 28 | let specialize_using reduce env f args sigma = 29 | reduce env sigma (mkAppl (f, args)) 30 | 31 | let specialize = specialize_using reduce_term 32 | 33 | let specialize_delta_f env f args sigma = 34 | let f = unwrap_definition env f in 35 | specialize env f args sigma 36 | 37 | (* --- Packing--- *) 38 | 39 | (* 40 | * Pack inside of a sigT or prod type 41 | *) 42 | let pack env l unpacked sigma = 43 | match l.orn.kind with 44 | | Algebraic (_, off) -> 45 | let sigma, typ = reduce_type env sigma unpacked in 46 | let index = get_arg off typ in 47 | let sigma, index_type = infer_type env sigma index in 48 | let sigma, packer = abstract_arg env sigma off typ in 49 | sigma, pack_existT {index_type; packer; index; unpacked} 50 | | CurryRecord -> 51 | let sigma, typ = infer_type env sigma unpacked in 52 | let sigma, typ_red = specialize_delta_f env (first_fun typ) (unfold_args typ) sigma in 53 | sigma, eta_prod_rec unpacked typ_red 54 | | SwapConstruct _ | UnpackSigma -> 55 | sigma, unpacked 56 | | Custom _ -> 57 | failwith "unsupported" 58 | 59 | (* --- Unpacking for unpack ornaments --- *) 60 | 61 | let unpack_typ_args env_args b_sig_eq sigma = 62 | let eq_sig = dest_sigT b_sig_eq in 63 | let b_sig = dest_sigT eq_sig.index_type in 64 | let i_b_typ = b_sig.index_type in 65 | let b = b_sig.packer in 66 | let sigma, i_b = 67 | let env_eq_typ, eq_typ = zoom_lambda_term env_args eq_sig.packer in 68 | let sigma, eq_typ = reduce_nf env_eq_typ sigma eq_typ in 69 | sigma, Debruijn.unshift (dest_eq eq_typ).trm2 70 | in sigma, [i_b_typ; b; i_b] 71 | 72 | (* --- Lifting --- *) 73 | 74 | (* 75 | * Lift 76 | *) 77 | let lift env l trm typ_args sigma = 78 | let f = lift_to l in 79 | sigma, mkAppl (f, snoc trm typ_args) 80 | 81 | (* --- Refolding --- *) 82 | 83 | (* 84 | * The implementation uses a refolding 85 | * algorithm to determine the constructor lifting rules, so that 86 | * they do not need to depend on ordering information. 87 | *) 88 | 89 | (* 90 | * Get all recursive constants 91 | *) 92 | let rec all_recursive_constants env trm = 93 | let consts = all_const_subterms (fun _ _ -> true) (fun u -> u) () trm in 94 | let non_axioms = 95 | List.map 96 | Option.get 97 | (List.filter 98 | (Option.has_some) 99 | (List.map 100 | (fun c -> 101 | try 102 | let def = unwrap_definition env c in 103 | if not (equal def c || isInd def) then 104 | Some (c, def) 105 | else 106 | None 107 | with _ -> 108 | None) 109 | consts)) 110 | in 111 | let non_axiom_consts = List.map fst non_axioms in 112 | let defs = List.map snd non_axioms in 113 | unique 114 | equal 115 | (List.append 116 | non_axiom_consts 117 | (List.flatten (List.map (all_recursive_constants env) defs))) 118 | 119 | (* 120 | * Fold back constants after applying a function to the normalized form 121 | * Makes the produced lifted constructors dramatically nicer and faster 122 | * when they refer to functions 123 | *) 124 | let fold_back_constants env f trm = 125 | bind 126 | (bind (fun sigma -> reduce_nf env sigma trm) f) 127 | (fun x -> 128 | fold_left_state 129 | (fun red lifted sigma -> 130 | all_conv_substs env sigma (lifted, lifted) red) 131 | x 132 | (all_recursive_constants env trm)) 133 | 134 | (* Common refolding function with unification *) 135 | let refold_econv env (abs_red, abs) trm sigma = 136 | map_term_env_if_lazy 137 | (fun _ sigma _ t -> 138 | sigma, isApp t && not (is_or_applies (first_fun abs) t)) 139 | (fun env sigma (abs_red, abs) t -> 140 | try 141 | let sigma = the_conv_x env (EConstr.of_constr t) (EConstr.of_constr abs_red) sigma in 142 | sigma, abs 143 | with _ -> 144 | sigma, t) 145 | (map_tuple Debruijn.shift) 146 | env 147 | sigma 148 | (abs_red, abs) 149 | trm 150 | 151 | (* 152 | * Refolding an applied ornament in the forward direction 153 | *) 154 | let refold_fwd l orn env arg app_red sigma = 155 | let sigma, arg_typ = reduce_type env sigma arg in 156 | let typ_args = unfold_args arg_typ in 157 | let earg_typ = EConstr.of_constr arg_typ in 158 | let sigma, earg = new_evar env sigma earg_typ in 159 | let earg = EConstr.to_constr sigma earg in 160 | let sigma, orn_app_red = specialize_using reduce_nf env orn (snoc earg typ_args) sigma in 161 | let sigma, orn_app_red_conc = specialize_using reduce_nf env orn (snoc arg typ_args) sigma in 162 | let sigma, arg_lift = lift env l earg typ_args sigma in 163 | let sigma, arg_lift_conc = lift env l arg typ_args sigma in 164 | match l.orn.kind with 165 | | Algebraic (_, off) -> 166 | let app_red_ex = dest_existT app_red in 167 | let orn_app_red_ex = dest_existT orn_app_red in 168 | let orn_app_red_conc_ex = dest_existT orn_app_red_conc in 169 | let abstract env sigma = abstract_arg env sigma off in 170 | let sigma, packer = on_red_type_default abstract env sigma orn_app_red_ex.unpacked in 171 | let index_type = app_red_ex.index_type in 172 | let arg_sigT = { index_type ; packer } in 173 | let arg_indexer = project_index arg_sigT arg_lift in 174 | let arg_indexer_conc = project_index arg_sigT arg_lift_conc in 175 | let arg_value = project_value arg_sigT arg_lift in 176 | let arg_value_conc = project_value arg_sigT arg_lift_conc in 177 | let refold_index_fast = all_eq_substs (orn_app_red_conc_ex.index, arg_indexer_conc) in 178 | let refold_value_fast = all_eq_substs (orn_app_red_conc_ex.unpacked, arg_value_conc) in 179 | let refold_index = refold_econv env (orn_app_red_ex.index, arg_indexer) in 180 | let refold_value = refold_econv env (orn_app_red_ex.unpacked, arg_value) in 181 | let sigma, refolded_value = refold_value (refold_value_fast app_red_ex.unpacked) sigma in 182 | let sigma, refolded_index = refold_index (refold_index_fast refolded_value)sigma in 183 | pack env l refolded_index sigma 184 | | _ -> 185 | let refold_value_fast = all_eq_substs (orn_app_red_conc, arg_lift_conc) in 186 | let refold_value = refold_econv env (orn_app_red, arg_lift) in 187 | refold_value (refold_value_fast app_red) sigma 188 | 189 | (* 190 | * Refolding an applied ornament in the backwards direction 191 | *) 192 | let refold_bwd l orn env arg app_red sigma = 193 | let sigma, arg_typ = reduce_type env sigma arg in 194 | let earg_typ = EConstr.of_constr arg_typ in 195 | let sigma, earg = new_evar env sigma earg_typ in 196 | let earg = EConstr.to_constr sigma earg in 197 | let sigma, typ_args = 198 | match l.orn.kind with 199 | | Algebraic (_, off) -> 200 | non_index_typ_args off env sigma arg 201 | | _ -> 202 | sigma, unfold_args arg_typ 203 | in 204 | let sigma, orn_app_red = specialize_using reduce_nf env orn (snoc earg typ_args) sigma in 205 | let sigma, orn_app_red_conc = specialize_using reduce_nf env orn (snoc arg typ_args) sigma in 206 | let sigma, arg_value = lift env l earg typ_args sigma in 207 | let sigma, arg_value_conc = lift env l arg typ_args sigma in 208 | let refold_value_fast = all_eq_substs (orn_app_red_conc, arg_value_conc) in 209 | let refold_value = refold_econv env (orn_app_red, arg_value) in 210 | refold_value (refold_value_fast app_red) sigma 211 | 212 | (* 213 | * Top-level refolding 214 | *) 215 | let refold l env orn trm args sigma = 216 | let refolder = if l.is_fwd then refold_fwd else refold_bwd in 217 | let refold_all = fold_right_state (refolder l orn env) args in 218 | fold_back_constants env refold_all trm sigma 219 | 220 | 221 | 222 | 223 | 224 | 225 | -------------------------------------------------------------------------------- /plugin/src/components/specialization.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Specialization component 3 | *) 4 | 5 | open Constr 6 | open Environ 7 | open Evd 8 | open Lifting 9 | open Stateutils 10 | open Reducers 11 | 12 | (* --- Packing --- *) 13 | 14 | (* Pack a term before lifting *) 15 | val pack : env -> lifting -> types -> evar_map -> types state 16 | 17 | (* --- Unpacking for unpack ornaments --- *) 18 | 19 | val unpack_typ_args : env -> constr -> evar_map -> (constr list) state 20 | 21 | (* --- Specialization --- *) 22 | 23 | val specialize_using : 24 | reducer -> env -> constr -> constr list -> evar_map -> constr state 25 | 26 | val specialize : 27 | env -> constr -> constr list -> evar_map -> constr state 28 | 29 | val specialize_delta_f : 30 | env -> constr -> constr list -> evar_map -> constr state 31 | 32 | (* --- Applying promote/forget --- *) 33 | 34 | (* 35 | * Apply promote/forget (forwards/backwards) to a term 36 | *) 37 | val lift : 38 | env -> lifting -> constr -> types list -> evar_map -> constr state 39 | 40 | (* --- Refolding --- *) 41 | 42 | (* 43 | * Apply and refold by an ornament function. This takes, in order: 44 | * 1) the lifting 45 | * 2) the environment 46 | * 3) the promote/forget function that is applied 47 | * 4) a term which is that promote/forget function applied to some arguments 48 | * 5) the evar map 49 | * 6) the inner arguments to refold by 50 | *) 51 | val refold : 52 | lifting -> env -> types -> types -> types list -> evar_map -> types state 53 | -------------------------------------------------------------------------------- /plugin/src/frontend.mli: -------------------------------------------------------------------------------- 1 | open Constrexpr 2 | open Names 3 | 4 | (* 5 | * Identify an algebraic ornament between two types 6 | * Define the components of the corresponding equivalence 7 | * If the appropriate option is set, prove that these form an equivalence 8 | *) 9 | val find_ornament : ?hints:string list -> Id.t option -> constr_expr -> constr_expr -> int option -> unit 10 | 11 | (* 12 | * Save a user-supplied equivalence between two types. 13 | * The boolean denotes a custom kind of equivalence (that is, not one of 14 | * the supported kinds, like the supported algebraic ornaments and so on). 15 | * If only one of two functions is supplied, automatically invert for 16 | * non-custom equivalences. 17 | * If the appropriate option is set, prove that these form an equivalence 18 | * for non-custom ornaments. 19 | *) 20 | val save_ornament : 21 | constr_expr -> 22 | constr_expr -> 23 | constr_expr option -> 24 | constr_expr option -> 25 | bool -> 26 | unit 27 | 28 | (* 29 | * Lift the supplied function along an ornament between the supplied types 30 | * Define the lifted version 31 | *) 32 | val lift_by_ornament : ?suffix:bool -> ?opaques:Libnames.qualid list -> ?hints:string list -> Id.t -> constr_expr -> constr_expr -> constr_expr -> bool -> unit 33 | 34 | (* 35 | * Lift each module element (constant and inductive definitions) along the given 36 | * ornament, defining a new module with all the transformed module elements. 37 | *) 38 | val lift_module_by_ornament : ?opaques:Libnames.qualid list -> ?hints:string list -> Id.t -> constr_expr -> constr_expr -> Libnames.qualid -> unit 39 | 40 | (* 41 | * Lift (transform) and then decompile for tactic suggestions 42 | *) 43 | val repair : ?suffix:bool -> ?opaques:Libnames.qualid list -> ?hints:string list -> Id.t -> constr_expr -> constr_expr -> constr_expr -> bool -> unit 44 | 45 | (* 46 | * Whole module lift (transform) and decompile for tactic suggestions 47 | *) 48 | val repair_module : ?opaques:Libnames.qualid list -> ?hints:string list -> Id.t -> constr_expr -> constr_expr -> Libnames.qualid -> unit 49 | 50 | (* 51 | * Unpack sigma types in the functional signature of a constant. 52 | * 53 | * This transformation assumes that the input constant was generated by 54 | * ornamental lifting. 55 | *) 56 | val do_unpack_constant : Id.t -> Libnames.qualid -> unit 57 | 58 | (* 59 | * Add terms to or remove terms from the globally opaque lifting cache 60 | * at a particular ornament 61 | *) 62 | val add_lifting_opaques : 63 | constr_expr -> constr_expr -> Libnames.qualid list -> unit 64 | val remove_lifting_opaques : 65 | constr_expr -> constr_expr -> Libnames.qualid list -> unit 66 | 67 | (* 68 | * Manual configuration 69 | *) 70 | val configure_manual : 71 | constr_expr -> (* A *) 72 | constr_expr -> (* B *) 73 | (Libnames.qualid list) * (Libnames.qualid list) -> (* DepConstr *) 74 | (Libnames.qualid * Libnames.qualid) -> (* DepElim *) 75 | (Libnames.qualid * Libnames.qualid) -> (* Eta *) 76 | (Libnames.qualid list) * (Libnames.qualid list) -> (* Iota *) 77 | unit 78 | -------------------------------------------------------------------------------- /plugin/src/lib/deltautils.ml: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Envutils 3 | 4 | (* --- Utilities for delta reduction --- *) 5 | 6 | (* 7 | * Delta-reduce until we hit an inductive type, or otherwise return the original 8 | *) 9 | let try_delta_inductive env trm = 10 | let unr = unwrap_definition env trm in 11 | if isInd unr then unr else trm 12 | -------------------------------------------------------------------------------- /plugin/src/lib/deltautils.mli: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Environ 3 | 4 | (* --- Utilities for delta reduction --- *) 5 | 6 | (* 7 | * Delta-reduce until we hit an inductive type, or otherwise return the original 8 | *) 9 | val try_delta_inductive : env -> constr -> constr 10 | -------------------------------------------------------------------------------- /plugin/src/lib/desugarprod.ml: -------------------------------------------------------------------------------- 1 | (* 2 | * These are the produtils from the library, but extended to automatically 3 | * also preprocess rather than produce terms with match statements 4 | *) 5 | 6 | open Constr 7 | open Envutils 8 | open Apputils 9 | open Nametab 10 | open Libnames 11 | open Produtils 12 | open Reducers 13 | open Inference 14 | 15 | (* --- Constants --- *) 16 | 17 | let prod : types = prod 18 | let pair : constr = pair 19 | let prod_rect : constr = prod_rect 20 | 21 | (* 22 | * Override fst and snd 23 | *) 24 | let fst_elim () : constr = 25 | mkConst (locate_constant (qualid_of_string "Ornamental.Prod.fst")) 26 | 27 | (* Second projection *) 28 | let snd_elim () : constr = 29 | mkConst (locate_constant (qualid_of_string "Ornamental.Prod.snd")) 30 | 31 | (* --- Representations --- *) 32 | 33 | let apply_pair = apply_pair 34 | let dest_pair = dest_pair 35 | let apply_prod = apply_prod 36 | let dest_prod = dest_prod 37 | let elim_prod = elim_prod 38 | let dest_prod_elim = dest_prod_elim 39 | 40 | (* 41 | * First projection of a prod 42 | *) 43 | let prod_fst_elim (app : prod_app) trm = 44 | mkAppl (fst_elim (), Produtils.[app.typ1; app.typ2; trm]) 45 | 46 | (* 47 | * Second projection of a prod 48 | *) 49 | let prod_snd_elim (app : prod_app) trm = 50 | mkAppl (snd_elim (), Produtils.[app.typ1; app.typ2; trm]) 51 | 52 | (* 53 | * Both projections of a prod 54 | *) 55 | let prod_projections_elim (app : prod_app) trm = 56 | (prod_fst_elim app trm, prod_snd_elim app trm) 57 | 58 | (* --- Extra utilities --- *) 59 | 60 | (* 61 | * Both types of a prod 62 | *) 63 | let prod_typs (p : prod_app) = 64 | p.typ1, p.typ2 65 | 66 | (* 67 | * All types of a nested prod 68 | *) 69 | let prod_typs_rec typ = 70 | let rec prod_args typ = 71 | if is_or_applies prod typ then 72 | let typ_prod = dest_prod typ in 73 | let (typ1, typ2) = prod_typs typ_prod in 74 | typ1 :: prod_args typ2 75 | else 76 | [typ] 77 | in prod_args typ 78 | 79 | (* 80 | * n types of a nested prod 81 | *) 82 | let prod_typs_rec_n typ n = 83 | let rec prod_args typ n = 84 | if n <= 1 then 85 | [typ] 86 | else 87 | if is_or_applies prod typ then 88 | let typ_prod = dest_prod typ in 89 | let (typ1, typ2) = prod_typs typ_prod in 90 | typ1 :: prod_args typ2 (n - 1) 91 | else 92 | [typ] 93 | in prod_args typ n 94 | 95 | (* 96 | * Eta expansion of a prod 97 | *) 98 | let eta_prod trm typ = 99 | if is_or_applies prod typ then 100 | let typ_prod = dest_prod typ in 101 | let (typ1, typ2) = prod_typs typ_prod in 102 | let (trm1, trm2) = prod_projections_elim typ_prod trm in 103 | apply_pair {typ1; typ2; trm1; trm2} 104 | else 105 | trm 106 | 107 | (* 108 | * Eta expansion of a nested prod 109 | *) 110 | let eta_prod_rec trm typ = 111 | let rec eta trm typ = 112 | if is_or_applies prod typ then 113 | let typ_prod = dest_prod typ in 114 | let (typ1, typ2) = prod_typs typ_prod in 115 | let (trm1, trm2) = prod_projections_elim typ_prod trm in 116 | let trm2 = eta trm2 typ2 in 117 | apply_pair {typ1; typ2; trm1; trm2} 118 | else 119 | trm 120 | in eta trm typ 121 | 122 | (* 123 | * Like dest_prod, but over the term's type 124 | *) 125 | let dest_prod_type env trm sigma = 126 | let sigma, typ = reduce_type env sigma trm in 127 | let typ_f = unwrap_definition env (first_fun typ) in 128 | let typ_args = unfold_args typ in 129 | let typ_red = mkAppl (typ_f, typ_args) in 130 | let sigma, typ_red = reduce_term env sigma typ_red in 131 | if is_or_applies prod typ_red then 132 | sigma, dest_prod typ_red 133 | else 134 | failwith "not a product" 135 | 136 | (* 137 | * Recursively project a nested product 138 | *) 139 | let prod_projections_rec env trm sigma = 140 | let rec proj trm sigma = 141 | try 142 | let sigma, typ_prod = dest_prod_type env trm sigma in 143 | let trm_fst, trm_snd = prod_projections_elim typ_prod trm in 144 | let sigma, proj_tl = proj trm_snd sigma in 145 | sigma, trm_fst :: proj_tl 146 | with _ -> 147 | sigma, [trm] 148 | in proj trm sigma 149 | 150 | (* 151 | * Project all of the terms out of a pair, eta expanding each one 152 | * Stop when there are n left 153 | *) 154 | let pair_projections_eta_rec_n trm n = 155 | let rec proj trm n = 156 | let p = dest_pair trm in 157 | let (trm1, trm2) = p.Produtils.trm1, p.Produtils.trm2 in 158 | if n <= 2 then 159 | [trm1; trm2] 160 | else 161 | if applies pair trm2 then 162 | trm1 :: proj trm2 (n - 1) 163 | else 164 | let typ2 = p.Produtils.typ2 in 165 | let trm2_eta = eta_prod trm2 typ2 in 166 | trm1 :: proj trm2_eta (n - 1) 167 | in proj trm n 168 | 169 | (* 170 | * Recursively pack a list of arguments into a pair 171 | * Fail if the list is empty 172 | *) 173 | let pack_pair_rec env trms sigma = 174 | let rec pack trms sigma = 175 | match trms with 176 | | trm1 :: (h :: tl) -> 177 | let sigma, typ1 = infer_type env sigma trm1 in 178 | let sigma, trm2 = pack (h :: tl) sigma in 179 | let sigma, typ2 = infer_type env sigma trm2 in 180 | sigma, apply_pair Produtils.{ typ1; typ2; trm1; trm2 } 181 | | h :: tl -> 182 | sigma, h 183 | | _ -> 184 | failwith "called pack_pair_rec with an empty list" 185 | in pack trms sigma 186 | -------------------------------------------------------------------------------- /plugin/src/lib/desugarprod.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * These are the produtils from the library, but extended to automatically 3 | * also preprocess rather than produce terms with match statements 4 | *) 5 | 6 | open Constr 7 | open Produtils 8 | open Environ 9 | open Evd 10 | open Stateutils 11 | 12 | (* --- Constants --- *) 13 | 14 | (* 15 | * These are unchanged 16 | *) 17 | val prod : types 18 | val pair : constr 19 | val prod_rect : constr 20 | 21 | (* 22 | * These are changed to use eliminators rather than match statements 23 | *) 24 | val fst_elim : unit -> constr 25 | val snd_elim : unit -> constr 26 | 27 | (* --- Representations --- *) 28 | 29 | (* 30 | * These are unchanged 31 | *) 32 | val apply_pair : pair_app -> constr 33 | val dest_pair : constr -> pair_app 34 | val apply_prod : prod_app -> types 35 | val dest_prod : types -> prod_app 36 | val elim_prod : prod_elim -> constr 37 | val dest_prod_elim : constr -> prod_elim 38 | 39 | (* 40 | * These are changed to use eliminators rather than match statements 41 | *) 42 | val prod_fst_elim : prod_app -> constr -> constr 43 | val prod_snd_elim : prod_app -> constr -> constr 44 | val prod_projections_elim : prod_app -> constr -> constr * constr 45 | 46 | (* --- Extra utilities --- *) 47 | 48 | val prod_typs : prod_app -> (types * types) 49 | val prod_typs_rec : types -> types list 50 | val prod_typs_rec_n : types -> int -> types list 51 | val eta_prod : constr -> types -> constr 52 | val eta_prod_rec : constr -> types -> constr 53 | val prod_projections_rec : env -> constr -> evar_map -> (constr list) state 54 | val pair_projections_eta_rec_n : constr -> int -> constr list 55 | val dest_prod_type : env -> constr -> evar_map -> prod_app state 56 | val pack_pair_rec : env -> (*nonempty*) constr list -> evar_map -> constr state 57 | -------------------------------------------------------------------------------- /plugin/src/lib/ornerrors.ml: -------------------------------------------------------------------------------- 1 | open Utilities 2 | open CErrors 3 | open Himsg 4 | open Constr 5 | 6 | (* 7 | * Errors and error messages 8 | *) 9 | 10 | (* --- Exceptions --- *) 11 | 12 | exception NotEliminators 13 | exception NotInductive 14 | exception NotAlgebraic 15 | 16 | (* --- Error descriptions --- *) 17 | 18 | let err_unsupported_change = Pp.str "Change not yet supported." 19 | 20 | let err_name_inference = 21 | Pp.str "Could not automatically determine name for new ornament." 22 | 23 | let err_new_parameter = Pp.str "New parameters not yet supported." 24 | 25 | let err_new_constructor = Pp.str "New constructors not yet supported." 26 | 27 | let err_save_ornament = Pp.str "Failed to save ornament." 28 | 29 | let err_unexpected_change expected_kind = 30 | Pp.seq 31 | [Pp.str "DEVOID expected an "; 32 | Pp.str expected_kind; 33 | Pp.str "."] 34 | 35 | let err_opaque_not_constant qid = 36 | Pp.seq 37 | [Pp.str "The identifier "; 38 | Libnames.pr_qualid qid; 39 | Pp.str " that was passed to the { opaque ... } option is not a constant,"; 40 | Pp.str " or does not exist."] 41 | 42 | let err_type env sigma err = 43 | Pp.seq 44 | [Pp.str "DEVOID tried to produce a term that is not well-typed. "; 45 | Pp.str "Coq gave us this scary looking error:\n"; 46 | Pp.fnl (); 47 | explain_pretype_error env sigma err; 48 | Pp.fnl (); 49 | Pp.fnl (); 50 | Pp.str "This is often due to one of three issues:\n"; 51 | Pp.str "1. during lifting, the term refers to an earlier term that is opaque, or\n"; 52 | Pp.str "2. during lifting, the term contains match statements that are not preprocessed.\n"; 53 | Pp.str "3. during search or lifting, a type or term is not supported, but we do not correctly detect this."] 54 | 55 | let err_ambiguous_swap env num_solutions swap_maps sigma = 56 | let print_swap_map i swap_map = 57 | Pp.seq 58 | [Pp.int i; 59 | Pp.str ") "; 60 | (Pp.prlist_with_sep 61 | (fun _ -> Pp.str ", ") 62 | (fun (c_o, c_n) -> 63 | Pp.prlist_with_sep 64 | (fun _ -> Pp.str " <-> ") 65 | (Printer.pr_constr_env env sigma) 66 | [mkConstructU c_o; mkConstructU c_n]) 67 | swap_map); 68 | Pp.fnl ()] 69 | in 70 | Pp.seq 71 | [Pp.str "DEVOID found "; 72 | Pp.str num_solutions; 73 | Pp.str " possible mappings for constructors. "; 74 | Pp.str "Showing up to the first 50:"; 75 | Pp.fnl (); 76 | Pp.seq (List.mapi print_swap_map swap_maps); 77 | Pp.fnl (); 78 | Pp.str "Please choose the mapping you'd like to use. "; 79 | Pp.str "Then, pass that to DEVOID by calling `Find ornament` again. "; 80 | Pp.str "For example: `Find ornament old new { mapping 0 }`. "; 81 | Pp.str "If the mapping you want is not in the 50 shown, "; 82 | Pp.str "please pass the mapping to `Save ornament` instead."] 83 | 84 | 85 | (* --- Possible workaround suggestions --- *) 86 | 87 | let try_name = Pp.str "passing a name explicitly to `Find ornament`" 88 | let try_opaque = Pp.str "skipping subterms using the `{ opaque ... }` option" 89 | let try_not_opaque = Pp.str "unsetting some subterms that are set as opaque" 90 | let try_preprocess = Pp.str "preprocessing the definition first" 91 | let try_check_typos = Pp.str "checking for typos" 92 | let try_fully_qualify = Pp.str "fully qualifying the identifier" 93 | let try_supported = Pp.str "using similar, supported types" 94 | let try_provide = Pp.str "providing your own ornament using `Save ornament`" 95 | 96 | let workaround suggestions = 97 | Pp.seq 98 | [Pp.str "To get around this, consider "; 99 | Pp.prlist_with_sep (fun _ -> Pp.str ", or ") id suggestions; 100 | Pp.str "."] 101 | 102 | (* --- Suggestion to read the FAQ --- *) 103 | 104 | let read_faq = 105 | Pp.str "Please see the README in uwplse/ornamental-search for more information." 106 | 107 | (* --- Reasons to cut an issue --- *) 108 | 109 | let cool_feature = Pp.str "you really want this feature" 110 | let problematic = Pp.str "this continues to cause you trouble" 111 | let mistake = Pp.str "you believe this should already be supported" 112 | 113 | let cut_issue reasons = 114 | Pp.seq 115 | [Pp.str "If "; 116 | Pp.prlist_with_sep (fun _ -> Pp.str ", or if ") id reasons; 117 | Pp.str ", then please cut an issue in the uwplse/ornamental-search repository."] 118 | 119 | (* --- Putting these together --- *) 120 | 121 | (* 122 | * Our own user_err function to make it easier to present nice information 123 | * to the user 124 | *) 125 | let user_err hdr err suggestions reasons = 126 | user_err 127 | ~hdr:hdr 128 | (Pp.prlist_with_sep 129 | Pp.spc 130 | id 131 | [err; workaround suggestions; read_faq; cut_issue reasons]) 132 | -------------------------------------------------------------------------------- /plugin/src/lib/ornerrors.mli: -------------------------------------------------------------------------------- 1 | open Environ 2 | open Evd 3 | open Constr 4 | 5 | (* 6 | * Errors and error messages 7 | *) 8 | 9 | (* --- Exceptions --- *) 10 | 11 | exception NotEliminators 12 | exception NotInductive 13 | exception NotAlgebraic 14 | 15 | (* --- Error descriptions --- *) 16 | 17 | val err_unsupported_change : Pp.t 18 | val err_name_inference : Pp.t 19 | val err_new_parameter : Pp.t 20 | val err_new_constructor : Pp.t 21 | val err_save_ornament : Pp.t 22 | val err_unexpected_change : String.t -> Pp.t 23 | val err_type : env -> evar_map -> Pretype_errors.pretype_error -> Pp.t 24 | val err_opaque_not_constant : Libnames.qualid -> Pp.t 25 | val err_ambiguous_swap : 26 | env -> string -> ((pconstructor * pconstructor) list) list -> evar_map -> Pp.t 27 | 28 | (* --- Possible workaround suggestions --- *) 29 | 30 | val try_name : Pp.t 31 | val try_opaque : Pp.t 32 | val try_not_opaque : Pp.t 33 | val try_preprocess : Pp.t 34 | val try_check_typos : Pp.t 35 | val try_fully_qualify : Pp.t 36 | val try_supported : Pp.t 37 | val try_provide : Pp.t 38 | 39 | (* --- Reasons to cut an issue --- *) 40 | 41 | val cool_feature : Pp.t 42 | val problematic : Pp.t 43 | val mistake : Pp.t 44 | 45 | (* --- Putting these together --- *) 46 | 47 | (* 48 | * Our own user_err function to make it easier to present nice information 49 | * to the user 50 | *) 51 | val user_err : 52 | String.t -> (* where you're calling it from *) 53 | Pp.t -> (* error description *) 54 | Pp.t list -> (* workaround suggestions *) 55 | Pp.t list -> (* reasons to cut an issue *) 56 | 'a 57 | -------------------------------------------------------------------------------- /plugin/src/lib/unificationutils.ml: -------------------------------------------------------------------------------- 1 | open Stateutils 2 | open Evarutil 3 | open Envutils 4 | open Evarconv 5 | open Utilities 6 | 7 | (* 8 | * Utilities for unification 9 | *) 10 | 11 | (* 12 | * Make n new evars of any type 13 | *) 14 | let mk_n_evars n env = 15 | map_state 16 | (fun r sigma -> 17 | let sigma, (earg_typ, _) = new_type_evar env sigma Evd.univ_flexible in 18 | let sigma, earg = new_evar env sigma earg_typ in 19 | sigma, EConstr.to_constr sigma earg) 20 | (mk_n_rels n) 21 | 22 | (* 23 | * Internal call to unification that takes econstrs 24 | *) 25 | let eunify env etrm1 etrm2 sigma = 26 | try 27 | the_conv_x env etrm1 etrm2 sigma, true 28 | with _ -> 29 | sigma, false 30 | 31 | (* 32 | * Try unification, but catch errors and return the appropriate evar_map 33 | *) 34 | let unify env trm1 trm2 sigma = 35 | eunify env (EConstr.of_constr trm1) (EConstr.of_constr trm2) sigma 36 | 37 | (* 38 | * Unify and force evar resolution 39 | * Return None if cannot unify or cannot resolve evars 40 | *) 41 | let unify_resolve_evars env trm1 trm2 sigma = 42 | let etrm1, etrm2 = map_tuple EConstr.of_constr (trm1, trm2) in 43 | let sigma, unifies = eunify env etrm1 etrm2 sigma in 44 | if unifies then 45 | let sigma_ref = ref sigma in 46 | try 47 | let etrm1 = Typing.e_solve_evars env sigma_ref etrm1 in 48 | let etrm2 = Typing.e_solve_evars env sigma_ref etrm2 in 49 | let sigma = !sigma_ref in 50 | sigma, Some (map_tuple (EConstr.to_constr sigma) (etrm1, etrm2)) 51 | with _ -> 52 | sigma, None 53 | else 54 | sigma, None 55 | -------------------------------------------------------------------------------- /plugin/src/lib/unificationutils.mli: -------------------------------------------------------------------------------- 1 | open Environ 2 | open Evd 3 | open Constr 4 | open Stateutils 5 | 6 | (* 7 | * Utilities for unification 8 | *) 9 | 10 | (* 11 | * Make n new evars of any type 12 | *) 13 | val mk_n_evars : 14 | int -> env -> evar_map -> (constr list) state 15 | 16 | (* 17 | * Unification 18 | *) 19 | val unify : 20 | env -> constr -> constr -> evar_map -> bool state 21 | 22 | (* 23 | * Unify the first two terms and then force evar resolution 24 | * Return None if cannot unify or cannot resolve evars 25 | *) 26 | val unify_resolve_evars : 27 | env -> constr -> constr -> evar_map -> ((constr * constr) option) state 28 | 29 | -------------------------------------------------------------------------------- /plugin/src/options.ml: -------------------------------------------------------------------------------- 1 | 2 | (* --- Options for DEVOID --- *) 3 | 4 | (* 5 | * Prove the coherence property of the algebraic promotion isomorphism 6 | * (disabled by default) 7 | *) 8 | let opt_search_coh = ref (false) 9 | let _ = Goptions.declare_bool_option { 10 | Goptions.optdepr = false; 11 | Goptions.optname = "Generate a proof of coherence in search for DEVOID"; 12 | Goptions.optkey = ["DEVOID"; "search"; "prove"; "coherence"]; 13 | Goptions.optread = (fun () -> !opt_search_coh); 14 | Goptions.optwrite = (fun b -> opt_search_coh := b); 15 | } 16 | 17 | let is_search_coh () = !opt_search_coh 18 | 19 | (* 20 | * Prove section and retraction 21 | * (disabled by default) 22 | *) 23 | let opt_search_equiv = ref (false) 24 | let _ = Goptions.declare_bool_option { 25 | Goptions.optdepr = false; 26 | Goptions.optname = "Generate proof of equivalence in search for DEVOID"; 27 | Goptions.optkey = ["DEVOID"; "search"; "prove"; "equivalence"]; 28 | Goptions.optread = (fun () -> !opt_search_equiv); 29 | Goptions.optwrite = (fun b -> opt_search_equiv := b); 30 | } 31 | 32 | let is_search_equiv () = !opt_search_equiv 33 | 34 | (* 35 | * Generate useful eliminators in addition to the discovered equivalence 36 | * (disabled by default) 37 | *) 38 | let opt_smart_elim = ref (false) 39 | let _ = Goptions.declare_bool_option { 40 | Goptions.optdepr = false; 41 | Goptions.optname = "Generate useful eliminators for DEVOID"; 42 | Goptions.optkey = ["DEVOID"; "search"; "smart"; "eliminators"]; 43 | Goptions.optread = (fun () -> !opt_smart_elim); 44 | Goptions.optwrite = (fun b -> opt_smart_elim := b); 45 | } 46 | 47 | let is_smart_elim () = !opt_smart_elim 48 | 49 | (* 50 | * Lift the type as well, rather than using the automatically inferred type 51 | * (disabled by default) 52 | *) 53 | let opt_lift_type = ref (false) 54 | let _ = Goptions.declare_bool_option { 55 | Goptions.optdepr = false; 56 | Goptions.optname = "Use lifted rather than inferred types in DEVOID"; 57 | Goptions.optkey = ["DEVOID"; "lift"; "type"]; 58 | Goptions.optread = (fun () -> !opt_lift_type); 59 | Goptions.optwrite = (fun b -> opt_lift_type := b); 60 | } 61 | 62 | let is_lift_type () = !opt_lift_type 63 | 64 | (* 65 | * If lifting a constant across an ornament does not change 66 | * the term, add that term to the global cache for later 67 | * (enabled by default) 68 | *) 69 | let opt_smart_cache = ref (true) 70 | let _ = Goptions.declare_bool_option { 71 | Goptions.optdepr = false; 72 | Goptions.optname = "Automatically cache unchanged lifted constants"; 73 | Goptions.optkey = ["DEVOID"; "smart"; "cache"]; 74 | Goptions.optread = (fun () -> !opt_smart_cache); 75 | Goptions.optwrite = (fun b -> opt_smart_cache := b); 76 | } 77 | 78 | let is_smart_cache () = !opt_smart_cache 79 | -------------------------------------------------------------------------------- /plugin/src/options.mli: -------------------------------------------------------------------------------- 1 | (* --- Options for DEVOID --- *) 2 | 3 | 4 | (* 5 | * Prove the coherence property of the algebraic promotion isomorphism 6 | * (disabled by default) 7 | *) 8 | val is_search_coh : unit -> bool 9 | 10 | (* 11 | * Prove section and retraction for the algebraic promotion isomorphism 12 | * (disabled by default) 13 | *) 14 | val is_search_equiv : unit -> bool 15 | 16 | (* 17 | * Generate useful eliminators in addition to the discovered equivalence 18 | * (disabled by default) 19 | *) 20 | val is_smart_elim : unit -> bool 21 | 22 | (* 23 | * Lift the type too, rather than letting Coq infer the type of a lifted term 24 | * (disabled by default) 25 | *) 26 | val is_lift_type : unit -> bool 27 | 28 | (* 29 | * Add unchanged lifted constants to the global lifting cache automatically 30 | * (enabled by default) 31 | *) 32 | val is_smart_cache : unit -> bool 33 | -------------------------------------------------------------------------------- /plugin/src/ornamental.ml4: -------------------------------------------------------------------------------- 1 | DECLARE PLUGIN "ornamental" 2 | 3 | open Stdarg 4 | open Frontend 5 | 6 | (* Identify an ornament given two types *) 7 | VERNAC COMMAND EXTEND FindOrnament CLASSIFIED AS SIDEFF 8 | | [ "Find" "ornament" constr(d_old) constr(d_new) "as" ident(n) ] -> 9 | [ find_ornament (Some n) d_old d_new None ] 10 | | [ "Find" "ornament" constr(d_old) constr(d_new) "as" ident(n) "{" "mapping" int(i) "}" ] -> 11 | [ find_ornament (Some n) d_old d_new (Some i) ] 12 | | [ "Find" "ornament" constr(d_old) constr(d_new) ] -> 13 | [ find_ornament None d_old d_new None ] 14 | | [ "Find" "ornament" constr(d_old) constr(d_new) "{" "mapping" int(i) "}" ] -> 15 | [ find_ornament None d_old d_new (Some i) ] 16 | END 17 | 18 | (* Save a user-supplied equivalence between two types *) 19 | VERNAC COMMAND EXTEND SaveOrnament CLASSIFIED AS SIDEFF 20 | | [ "Save" "ornament" constr(d_old) constr(d_new) "{" "promote" "=" constr(d_orn) ";" "forget" "=" constr(d_orn_inv) "}" ] -> 21 | [ save_ornament d_old d_new (Some d_orn) (Some d_orn_inv) false ] 22 | | [ "Save" "ornament" constr(d_old) constr(d_new) "{" "promote" "=" constr(d_orn) "}" ] -> 23 | [ save_ornament d_old d_new (Some d_orn) None false ] 24 | | [ "Save" "ornament" constr(d_old) constr(d_new) "{" "forget" "=" constr(d_orn_inv) "}" ] -> 25 | [ save_ornament d_old d_new None (Some d_orn_inv) false ] 26 | | [ "Save" "equivalence" constr(d_old) constr(d_new) "{" "promote" "=" constr(d_orn) ";" "forget" "=" constr(d_orn_inv) "}" ] -> 27 | [ save_ornament d_old d_new (Some d_orn) (Some d_orn_inv) true ] 28 | END 29 | 30 | (* Lift a function along an equivalence *) 31 | VERNAC COMMAND EXTEND LiftOrnament CLASSIFIED AS SIDEFF 32 | | [ "Lift" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ident(n)] -> 33 | [ lift_by_ornament n d_orn d_orn_inv d_old false ] 34 | | [ "Lift" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ident(n) "{" "opaque" ne_reference_list(opaques) "}" ] -> 35 | [ lift_by_ornament ~opaques:opaques n d_orn d_orn_inv d_old false ] 36 | | [ "Lift" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ".." ident(n)] -> 37 | [ lift_by_ornament ~suffix:true n d_orn d_orn_inv d_old false ] 38 | | [ "Lift" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ".." ident(n) "{" "opaque" ne_reference_list(opaques) "}" ] -> 39 | [ lift_by_ornament ~opaques:opaques ~suffix:true n d_orn d_orn_inv d_old false ] 40 | | [ "Lift" "Module" constr(d_orn) constr(d_orn_inv) "in" reference(mod_ref) "as" ident(id) ] -> 41 | [ lift_module_by_ornament id d_orn d_orn_inv mod_ref ] 42 | | [ "Lift" "Module" constr(d_orn) constr(d_orn_inv) "in" reference(mod_ref) "as" ident(id) "{" "opaque" ne_reference_list(opaques) "}" ] -> 43 | [ lift_module_by_ornament ~opaques:opaques id d_orn d_orn_inv mod_ref ] 44 | END 45 | 46 | (* Configure lifting with some additional information *) 47 | VERNAC COMMAND EXTEND ConfigureLift CLASSIFIED AS SIDEFF 48 | | [ "Configure" "Lift" constr(d_orn) constr(d_orn_inv) "{" "opaque" ne_reference_list(opaques) "}" ] -> 49 | [ add_lifting_opaques d_orn d_orn_inv opaques ] 50 | | [ "Configure" "Lift" constr(d_orn) constr(d_orn_inv) "{" "~" "opaque" ne_reference_list(opaques) "}"] -> 51 | [ remove_lifting_opaques d_orn d_orn_inv opaques ] 52 | | [ "Configure" "Lift" constr(d_orn) constr(d_orn_inv) "{" "constrs_a" "=" reference_list(constrs_a) ";" "constrs_b" "=" reference_list(constrs_b) ";" "elim_a" "=" reference(elim_a) ";" "elim_b" "=" reference(elim_b) ";" "eta_a" "=" reference(eta_a) ";" "eta_b" "=" reference(eta_b) ";" "iota_a" "=" reference_list(iota_a) ";" "iota_b" "=" reference_list(iota_b) "}" ] -> 53 | [ configure_manual d_orn d_orn_inv (constrs_a, constrs_b) (elim_a, elim_b) (eta_a, eta_b) (iota_a, iota_b) ] 54 | END 55 | 56 | (* Repair: lift (transform) and then decompile *) 57 | VERNAC COMMAND EXTEND RepairProof CLASSIFIED AS SIDEFF 58 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ident(n)] -> 59 | [ repair n d_orn d_orn_inv d_old false ] 60 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ident(n) "{" "opaque" ne_reference_list(opaques) "}" ] -> 61 | [ repair ~opaques:opaques n d_orn d_orn_inv d_old false ] 62 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ".." ident(n)] -> 63 | [ repair ~suffix:true n d_orn d_orn_inv d_old false ] 64 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ".." ident(n) "{" "opaque" ne_reference_list(opaques) "}" ] -> 65 | [ repair ~opaques:opaques ~suffix:true n d_orn d_orn_inv d_old false ] 66 | | [ "Repair" "Module" constr(d_orn) constr(d_orn_inv) "in" reference(mod_ref) "as" ident(id) ] -> 67 | [ repair_module id d_orn d_orn_inv mod_ref ] 68 | | [ "Repair" "Module" constr(d_orn) constr(d_orn_inv) "in" reference(mod_ref) "as" ident(id) "{" "opaque" ne_reference_list(opaques) "}" ] -> 69 | [ repair_module ~opaques:opaques id d_orn d_orn_inv mod_ref ] 70 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ident(n) "{" "hint" ne_string_list(hints) "}" ] -> 71 | [ repair ~hints:hints n d_orn d_orn_inv d_old false ] 72 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ident(n) "{" "opaque" ne_reference_list(opaques) ";" "hint" ne_string_list(hints) "}" ] -> 73 | [ repair ~opaques:opaques ~hints:hints n d_orn d_orn_inv d_old false ] 74 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ".." ident(n) "{" "hint" ne_string_list(hints) "}" ] -> 75 | [ repair ~suffix:true ~hints:hints n d_orn d_orn_inv d_old false ] 76 | | [ "Repair" constr(d_orn) constr(d_orn_inv) "in" constr(d_old) "as" ".." ident(n) "{" "opaque" ne_reference_list(opaques) ";" "hint" ne_string_list(hints) "}" ] -> 77 | [ repair ~opaques:opaques ~suffix:true ~hints:hints n d_orn d_orn_inv d_old false ] 78 | | [ "Repair" "Module" constr(d_orn) constr(d_orn_inv) "in" reference(mod_ref) "as" ident(id) "{" "hint" ne_string_list(hints) "}" ] -> 79 | [ repair_module ~hints:hints id d_orn d_orn_inv mod_ref ] 80 | | [ "Repair" "Module" constr(d_orn) constr(d_orn_inv) "in" reference(mod_ref) "as" ident(id) "{" "opaque" ne_reference_list(opaques) ";" "hint" ne_string_list(hints) "}" ] -> 81 | [ repair_module ~opaques:opaques ~hints:hints id d_orn d_orn_inv mod_ref ] 82 | END 83 | 84 | (* Register the Ltac script for sigma unpacking *) 85 | VERNAC COMMAND EXTEND UnpackSigma CLASSIFIED AS SIDEFF 86 | | [ "Unpack" reference(const_ref) "as" ident(id) ] -> 87 | [ do_unpack_constant id const_ref ] 88 | END 89 | -------------------------------------------------------------------------------- /plugin/src/ornaments.mlpack: -------------------------------------------------------------------------------- 1 | Utilities 2 | 3 | Apputils 4 | Constutils 5 | Funutils 6 | 7 | Defutils 8 | Nameutils 9 | 10 | Inference 11 | Convertibility 12 | Checking 13 | 14 | Equtils 15 | Sigmautils 16 | Produtils 17 | Idutils 18 | Proputils 19 | 20 | Stateutils 21 | Envutils 22 | Contextutils 23 | 24 | Hofs 25 | Debruijn 26 | Hofimpls 27 | Substitution 28 | Reducers 29 | Typehofs 30 | Zooming 31 | Hypotheses 32 | 33 | Indexing 34 | Indutils 35 | 36 | Modutils 37 | 38 | Printing 39 | 40 | Decompiler 41 | 42 | Deltautils 43 | Desugarprod 44 | Ornerrors 45 | Unificationutils 46 | 47 | Promotion 48 | 49 | Caching 50 | 51 | Lifting 52 | 53 | Factoring 54 | Abstraction 55 | Specialization 56 | Differencing 57 | 58 | Options 59 | 60 | Depelim 61 | Unpack 62 | 63 | Search 64 | Coherence 65 | Equivalence 66 | Smartelim 67 | 68 | Liftconfig 69 | Liftrules 70 | Lift 71 | 72 | Frontend 73 | Ornamental 74 | -------------------------------------------------------------------------------- /plugin/src/ornaments/lifting.mli: -------------------------------------------------------------------------------- 1 | (* 2 | * Datatypes for promotions and lifting 3 | *) 4 | 5 | open Constr 6 | open Environ 7 | open Evd 8 | open Promotion 9 | open Stateutils 10 | 11 | (* --- Datatypes --- *) 12 | 13 | (* 14 | * A lifting is an ornamental promotion between types and a direction, 15 | * This is a convenience configuration for lifting functions and proofs, 16 | * which wraps the promotion with extra useful information. 17 | *) 18 | type lifting = 19 | { 20 | orn : promotion; 21 | is_fwd : bool; 22 | } 23 | 24 | (* --- Initialization --- *) 25 | 26 | (* 27 | * Initialize a lifting for a cached equivalence, given (in order): 28 | * 1) an environment 29 | * 2) an evar_map 30 | * 3) the old type 31 | * 4) the new type 32 | *) 33 | val initialize_lifting_cached : 34 | env -> evar_map -> types -> types -> lifting state 35 | 36 | (* 37 | * Initialize a lifting for a user-supplied equivalence, given (in order): 38 | * 1) an environment 39 | * 2) an evar_map 40 | * 3) the old and new types 41 | * 4) the old and new user-supplied equivalence functions 42 | * 5) a boolean flag if it is a custom kind of equivalence 43 | *) 44 | val initialize_lifting_provided : 45 | env -> evar_map -> types * types -> constr * constr -> bool -> lifting state 46 | 47 | (* --- Control structures --- *) 48 | 49 | (* 50 | * These two functions determine what function to use to go back to 51 | * an old type or get to a new type when lifting 52 | *) 53 | val lift_back : lifting -> types 54 | val lift_to : lifting -> types 55 | 56 | (* Other control structures *) 57 | val directional : lifting -> 'a -> 'a -> 'a 58 | val map_directional : ('a -> 'b) -> ('a -> 'b) -> lifting -> 'a -> 'b 59 | val map_forward : ('a -> 'a) -> lifting -> 'a -> 'a 60 | val map_backward : ('a -> 'a) -> lifting -> 'a -> 'a 61 | 62 | (* --- Information retrieval --- *) 63 | 64 | (* 65 | * Given the type of an ornamental promotion function, get the types 66 | * that the function maps between, including all of their arguments. 67 | * It is up to the client to adjust the offsets appropriately. 68 | *) 69 | val promotion_type_to_types : types -> (types * types) 70 | 71 | (* 72 | * Determine whether a type is the type we are ornamenting from 73 | * (A in forward direction, B in backward direction) using unification. 74 | * We optimize this in liftconfig.ml depending on the kind of ornament. 75 | *) 76 | val e_is_from : 77 | env -> 78 | types -> (* eta-expanded A or B, depending on direction *) 79 | types -> (* type we are checking *) 80 | evar_map -> 81 | ((constr list) option) state 82 | 83 | (* --- Directionality --- *) 84 | 85 | (* 86 | * Flip the direction of a lifting 87 | *) 88 | val flip_dir : lifting -> lifting 89 | 90 | (* 91 | * Apply a function twice, once in each direction. 92 | * Compose the result into a tuple. 93 | *) 94 | val twice_directional : (lifting -> 'a) -> lifting -> ('a * 'a) 95 | 96 | (* --- Indexing for algebraic ornaments --- *) 97 | 98 | (* 99 | * Insert/remove the index at the appropriate offset. 100 | * Raise NotAlgebraic if not an algebraic ornament. 101 | *) 102 | val index : lifting -> constr -> constr list -> constr list 103 | val deindex : lifting -> constr list -> constr list 104 | 105 | -------------------------------------------------------------------------------- /plugin/src/ornaments/promotion.ml: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Declarations 3 | open Stateutils 4 | open Reducers 5 | open Zooming 6 | open Envutils 7 | open Apputils 8 | open Utilities 9 | open Environ 10 | 11 | (* --- Ornamental promotions --- *) 12 | 13 | (* 14 | * The kind of ornament that is stored 15 | *) 16 | type kind_of_orn = 17 | | Algebraic of constr * int 18 | | CurryRecord 19 | | SwapConstruct of (int * int) list 20 | | UnpackSigma 21 | | Custom of (types * types) 22 | 23 | (* 24 | * An ornamental promotion is a function from T1 -> T2, 25 | * a function from T2 -> T1, and a kind of ornament. 26 | *) 27 | type promotion = 28 | { 29 | promote : types; 30 | forget : types; 31 | kind : kind_of_orn; 32 | } 33 | 34 | (* 35 | * Get the swap map from the promotion or forgetful function, if one 36 | * is provided 37 | *) 38 | let swap_map_of_promote_or_forget env a b promote_o forget_o = 39 | let trm_o_o = if Option.has_some promote_o then promote_o else forget_o in 40 | let f = Option.get trm_o_o in 41 | let ((i_o, ii_o), u_o) = destInd (if Option.has_some promote_o then a else b) in 42 | let m_o = lookup_mind i_o env in 43 | let b_o = m_o.mind_packets.(0) in 44 | let cs_o = b_o.mind_consnames in 45 | let ncons = Array.length cs_o in 46 | map_state 47 | (fun i sigma -> 48 | let c_o = mkConstructU (((i_o, ii_o), i), u_o) in 49 | let sigma, c_o_typ = reduce_type env sigma c_o in 50 | let env_c_o, c_o_typ = zoom_product_type env c_o_typ in 51 | let nargs = new_rels2 env_c_o env in 52 | let c_o_args = mk_n_rels nargs in 53 | let c_o_app = mkAppl (c_o, c_o_args) in 54 | let typ_args = unfold_args c_o_typ in 55 | let sigma, c_o_lifted = reduce_nf env_c_o sigma (mkAppl (f, snoc c_o_app typ_args)) in 56 | let swap = ((((i_o, ii_o), i), u_o), destConstruct (first_fun c_o_lifted)) in 57 | sigma, if Option.has_some promote_o then swap else reverse swap) 58 | (range 1 (ncons + 1)) 59 | -------------------------------------------------------------------------------- /plugin/src/ornaments/promotion.mli: -------------------------------------------------------------------------------- 1 | open Constr 2 | open Environ 3 | open Evd 4 | open Stateutils 5 | 6 | (* --- Ornamental promotions --- *) 7 | 8 | (* 9 | * The kind of ornament that is stored 10 | *) 11 | type kind_of_orn = 12 | | Algebraic of constr * int 13 | | CurryRecord 14 | | SwapConstruct of (int * int) list 15 | | UnpackSigma 16 | | Custom of (types * types) 17 | 18 | (* 19 | * An ornamental promotion is a function from T1 -> T2, 20 | * a function from T2 -> T1, and a kind of ornament. 21 | *) 22 | type promotion = 23 | { 24 | promote : types; 25 | forget : types; 26 | kind : kind_of_orn; 27 | } 28 | 29 | (* --- Useful function for finding swaps from promotion function --- *) 30 | 31 | (* 32 | * This assumes exactly one of promote or forget is present 33 | *) 34 | val swap_map_of_promote_or_forget : 35 | env -> 36 | types -> (* a *) 37 | types -> (* b *) 38 | constr option -> (* promote, if present *) 39 | constr option -> (* forget, if present *) 40 | evar_map -> 41 | ((pconstructor * pconstructor) list) state 42 | -------------------------------------------------------------------------------- /plugin/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | lifted=false 4 | liftedind=false 5 | findlift=false 6 | liftedcase=false 7 | assumptions=false 8 | intro=false 9 | example=false 10 | liftspec=false 11 | search=false 12 | lift=false 13 | listtovect=false 14 | listtovectcustom=false 15 | records=false 16 | handshake=false 17 | morerecords=false 18 | smartcache=false 19 | nosmartcache=false 20 | prodrect=false 21 | swap=false 22 | unpack=false 23 | nonorn=false 24 | 25 | start=$SECONDS 26 | 27 | coqc coq/Infrastructure.v 28 | 29 | echo "Testing Find ornament." 30 | 31 | if coqc coq/Test.v 32 | then 33 | : 34 | else 35 | echo "ERROR: Searching for ornaments failed" 36 | exit 1 37 | fi 38 | 39 | echo "Testing Lift." 40 | 41 | if coqc coq/TestLift.v 42 | then 43 | lifted=true 44 | else 45 | : 46 | fi 47 | 48 | if coqc coq/Indtype.v 49 | then 50 | liftedind=true 51 | else 52 | : 53 | fi 54 | 55 | echo "Testing Lift with implicit Find Ornament." 56 | 57 | if coqc coq/TestFindLift.v 58 | then 59 | findlift=true 60 | else 61 | : 62 | fi 63 | 64 | echo "Testing Lift Record." 65 | 66 | if coqc coq/minimal_records.v 67 | then 68 | records=true 69 | else 70 | : 71 | fi 72 | 73 | if coqc coq/handshake.v 74 | then 75 | handshake=true 76 | else 77 | : 78 | fi 79 | 80 | if coqc coq/more_records.v 81 | then 82 | morerecords=true 83 | else 84 | : 85 | fi 86 | 87 | cd coq 88 | 89 | if coqc prod_rect.v 90 | then 91 | prodrect=true 92 | else 93 | : 94 | fi 95 | 96 | cd .. 97 | 98 | echo "Testing Swap Constructor." 99 | 100 | if coqc coq/Swap.v 101 | then 102 | swap=true 103 | else 104 | : 105 | fi 106 | 107 | echo "Testing Unpack Sigma." 108 | 109 | if coqc coq/TestUnpack.v 110 | then 111 | unpack=true 112 | else 113 | : 114 | fi 115 | 116 | echo "Testing Non-Ornaments." 117 | 118 | if coqc coq/nonorn.v 119 | then 120 | nonorn=true 121 | else 122 | : 123 | fi 124 | 125 | echo "Testing smart cache." 126 | echo "First, without the smart cache:" 127 | 128 | if coqc coq/NoSmartCache.v 129 | then 130 | nosmartcache=true 131 | else 132 | : 133 | fi 134 | 135 | echo "Now, with the smart cache:" 136 | 137 | if coqc coq/SmartCache.v 138 | then 139 | smartcache=true 140 | else 141 | : 142 | fi 143 | 144 | echo "Running case study code." 145 | 146 | cd eval 147 | 148 | if [ -e out ] 149 | then 150 | rm -r out 151 | else 152 | : 153 | fi 154 | 155 | mkdir out 156 | mkdir out/inorder 157 | mkdir out/postorder 158 | mkdir out/preorder 159 | mkdir out/search 160 | mkdir out/normalized 161 | mkdir out/inputs 162 | mkdir out/equivalences 163 | make clean 164 | ulimit -s 100000 165 | if make 166 | then 167 | liftedcase=true 168 | else 169 | : 170 | fi 171 | cd .. 172 | 173 | echo "Running ITP paper examples." 174 | 175 | if coqc coq/examples/Intro.v 176 | then 177 | intro=true 178 | else 179 | : 180 | fi 181 | 182 | if coqc coq/examples/Example.v 183 | then 184 | example=true 185 | else 186 | : 187 | fi 188 | 189 | if coqc coq/examples/Search.v 190 | then 191 | search=true 192 | else 193 | : 194 | fi 195 | 196 | if coqc coq/examples/LiftSpec.v 197 | then 198 | liftspec=true 199 | else 200 | : 201 | fi 202 | 203 | if coqc coq/examples/Assumptions.v 204 | then 205 | assumptions=true 206 | else 207 | : 208 | fi 209 | 210 | if coqc coq/examples/Lift.v 211 | then 212 | lift=true 213 | else 214 | : 215 | fi 216 | 217 | if coqc coq/examples/ListToVect.v 218 | then 219 | listtovect=true 220 | else 221 | : 222 | fi 223 | 224 | if coqc coq/examples/ListToVectCustom.v 225 | then 226 | listtovectcustom=true 227 | else 228 | : 229 | fi 230 | 231 | end=$SECONDS 232 | 233 | if [ $lifted = true ] && [ $liftedind = true ] && [ $findlift = true ] && 234 | [ $liftedcase = true ] && [ $assumptions = true ] && [ $intro = true ] && 235 | [ $example = true ] && [ $liftspec = true ] && [ $search = true ] && 236 | [ $lift = true ] && [ $listtovect = true ] && [ $listtovectcustom = true ] && [ $records = true ] && [ $handshake = true ] && 237 | [ $morerecords = true ] && [ $nosmartcache = true ] && [ $smartcache = true ] && [ $prodrect = true ] && 238 | [ $swap = true ] && [ $unpack = true ] && [ $nonorn = true ] 239 | then 240 | echo "SUCCESS: All tests passed." 241 | 242 | elapsed=($end - $start) 243 | echo "Tests took $elapsed seconds." 244 | else 245 | echo "ERROR: The following tests failed:" 246 | if [ $lifted = false ] 247 | then 248 | echo "lifting" 249 | else 250 | : 251 | fi 252 | if [ $findlift = false ] 253 | then 254 | echo "lifting with implicit Find Ornament" 255 | else 256 | : 257 | fi 258 | if [ $liftedind = false ] 259 | then 260 | echo "lifting inductive predicates" 261 | else 262 | : 263 | fi 264 | if [ $records = false ] 265 | then 266 | echo "lifting records to products: minimal test" 267 | else 268 | : 269 | fi 270 | if [ $handshake = false ] 271 | then 272 | echo "lifting records to products: record projection test" 273 | else 274 | : 275 | fi 276 | if [ $morerecords = false ] 277 | then 278 | echo "lifting records to products: fancier test" 279 | else 280 | : 281 | fi 282 | if [ $prodrect = false ] 283 | then 284 | echo "lifting records to products: folding projections" 285 | else 286 | : 287 | fi 288 | if [ $swap = false ] 289 | then 290 | echo "tests for swapping and renaming constructors" 291 | else 292 | : 293 | fi 294 | if [ $unpack = false ] 295 | then 296 | echo "tests for unpacking indexed types" 297 | else 298 | : 299 | fi 300 | if [ $nonorn = false ] 301 | then 302 | echo "tests for non-ornament equivalences" 303 | else 304 | : 305 | fi 306 | if [ $smartcache = false ] 307 | then 308 | echo "set smart cache test" 309 | else 310 | : 311 | fi 312 | if [ $nosmartcache = false ] 313 | then 314 | echo "unset smart cache test" 315 | else 316 | : 317 | fi 318 | if [ $liftedcase = false ] 319 | then 320 | echo "case study code" 321 | else 322 | : 323 | fi 324 | if [ $assumptions = false ] 325 | then 326 | echo "Assumptions.v from ITP examples" 327 | else 328 | : 329 | fi 330 | if [ $intro = false ] 331 | then 332 | echo "Intro.v from ITP examples" 333 | else 334 | : 335 | fi 336 | if [ $example = false ] 337 | then 338 | echo "Example.v from ITP examples" 339 | else 340 | : 341 | fi 342 | if [ $liftspec = false ] 343 | then 344 | echo "LiftSpec.v from ITP examples" 345 | else 346 | : 347 | fi 348 | if [ $search = false ] 349 | then 350 | echo "Search.v from ITP examples" 351 | else 352 | : 353 | fi 354 | if [ $lift = false ] 355 | then 356 | echo "Lift.v from ITP examples" 357 | else 358 | : 359 | fi 360 | if [ $listtovect = false ] 361 | then 362 | echo "ListToVect.v from ITP examples" 363 | else 364 | : 365 | fi 366 | if [ $listtovectcustom = false ] 367 | then 368 | echo "ListToVectCustom.v from extended ITP examples" 369 | else 370 | : 371 | fi 372 | echo "See Coq error message." 373 | fi 374 | 375 | -------------------------------------------------------------------------------- /plugin/theories/Adjoint.v: -------------------------------------------------------------------------------- 1 | (** Credit to Jasper Hugunin (jashug) for this module. 2 | * 3 | * MIT license, (c) Jasper Hugunin 4 | * Link: https://github.com/jashug/IWTypes/blob/master/Adjointification.v 5 | *) 6 | 7 | (* Turn a pair of inverses into an adjoint equivalence *) 8 | (* Proof follows the HoTT book *) 9 | (* Mostly, just a lot of manipulation of equality proofs *) 10 | 11 | (* Lemma 2.4.3 in HoTT book, specialized to g = id *) 12 | Definition commute_homotopy_id {A} {f : A -> A} 13 | (f_id : forall a, f a = a) {x y : A} (p : x = y) 14 | : eq_trans (f_id x) p = eq_trans (f_equal f p) (f_id y) 15 | := match p in (_ = y) 16 | return eq_trans (f_id x) p = eq_trans (f_equal f p) (f_id y) 17 | with eq_refl => eq_sym (eq_trans_refl_l (f_id x)) end. 18 | 19 | Section adjointify. 20 | Context {A B} (f : A -> B) (g : B -> A). 21 | 22 | Section g_adjoint. 23 | Context 24 | (gf_id : forall a, g (f a) = a) 25 | (fg_id : forall b, f (g b) = b). 26 | 27 | Definition f_adjoint_gives_g_adjoint_pointwise 28 | (b : B) (f_adjoint_at_gb : fg_id (f (g b)) = f_equal f (gf_id (g b))) 29 | : gf_id (g b) = f_equal g (fg_id b) 30 | := let precomposed_eq 31 | : eq_trans (f_equal (fun a => g (f a)) (f_equal g (fg_id b))) 32 | (gf_id (g b)) = 33 | eq_trans (f_equal g (f_equal (fun b => f (g b)) (fg_id b))) 34 | (f_equal g (fg_id b)) 35 | := eq_trans 36 | (eq_sym (commute_homotopy_id gf_id (f_equal g (fg_id b)))) 37 | (eq_rect (f_equal g (fg_id (f (g b)))) (fun p => eq_trans p _ = _) 38 | (eq_trans (eq_trans 39 | (eq_sym (eq_trans_map_distr g _ _)) 40 | (f_equal (fun p => f_equal g p) 41 | (commute_homotopy_id fg_id (fg_id b)))) 42 | (eq_trans_map_distr g _ _)) _ 43 | (eq_trans (eq_trans 44 | (f_equal (fun p => f_equal g p) f_adjoint_at_gb) 45 | (f_equal_compose f g _)) 46 | (eq_id_comm_r _ gf_id (g b)))) in 47 | match fg_id b as p 48 | return 49 | forall p1 p2, 50 | eq_trans (f_equal _ (f_equal g p)) p1 = 51 | eq_trans (f_equal g (f_equal _ p)) p2 -> 52 | p1 = p2 53 | with eq_refl => fun p1 p2 eq => 54 | eq_trans (eq_trans 55 | (eq_sym (eq_trans_refl_l _)) 56 | eq) 57 | (eq_trans_refl_l _) 58 | end (gf_id (g b)) (f_equal g (fg_id b)) precomposed_eq. 59 | 60 | Definition f_adjoint_gives_g_adjoint 61 | (f_adjoint : forall a, fg_id (f a) = f_equal f (gf_id a)) 62 | (b : B) : gf_id (g b) = f_equal g (fg_id b) 63 | := f_adjoint_gives_g_adjoint_pointwise b (f_adjoint (g b)). 64 | End g_adjoint. 65 | 66 | Section correction. 67 | Context 68 | (gf_id : forall a, g (f a) = a) 69 | (fg_id : forall b, f (g b) = b). 70 | 71 | (* N.B.: The adjoint equivalence will use this instead of the given section. *) 72 | Definition fg_id' b : f (g b) = b 73 | := eq_trans (eq_sym (fg_id (f (g b)))) 74 | (eq_trans (f_equal f (gf_id (g b))) (fg_id b)). 75 | 76 | Definition f_adjoint a : fg_id' (f a) = f_equal f (gf_id a) 77 | := let symmetric_eq 78 | : eq_trans (f_equal f (gf_id (g (f a)))) (fg_id (f a)) = 79 | eq_trans (fg_id (f (g (f a)))) (f_equal f (gf_id a)) 80 | := eq_trans (eq_trans 81 | (f_equal (fun H => eq_trans (f_equal f H) (fg_id (f a))) 82 | (eq_sym (eq_id_comm_r _ gf_id a))) 83 | (f_equal (fun p => eq_trans p _) 84 | (eq_trans 85 | (f_equal_compose (fun a => g (f a)) f _) 86 | (eq_sym (f_equal_compose f (fun b => f (g b)) _))))) 87 | (eq_sym (commute_homotopy_id fg_id (f_equal f (gf_id a)))) in 88 | match fg_id (f (g (f a))) as p 89 | return forall p', _ = eq_trans p p' -> eq_trans (eq_sym p) _ = p' 90 | with eq_refl => fun p' eq => 91 | eq_trans (eq_trans_refl_l _) (eq_trans eq (eq_trans_refl_l _)) 92 | end _ symmetric_eq. 93 | 94 | Definition g_adjoint 95 | : forall b, gf_id (g b) = f_equal g (fg_id' b) 96 | := f_adjoint_gives_g_adjoint gf_id fg_id' f_adjoint. 97 | 98 | End correction. 99 | 100 | End adjointify. 101 | -------------------------------------------------------------------------------- /plugin/theories/Eliminators.v: -------------------------------------------------------------------------------- 1 | (* 2 | * This file contains useful custom eliminators for ornaments. 3 | *) 4 | 5 | (* 6 | * Useful eliminator for algebraic ornaments in packed form, like 7 | * { l : list T & length l = n }. See coq/examples/Example.v for use 8 | * of this eliminator. Note that lifting assumes pa in the conclusion 9 | * is eta-expanded to (existT _ (projT1 pa) (projT2 pa)) for now. 10 | *) 11 | Lemma packed_rect (A : Type) {I_B : Type} (indexer : A -> I_B) (exp : A -> A) (coh : forall i_b a, indexer a = i_b -> indexer (exp a) = i_b): 12 | forall (i_b : I_B) (P : { a : A & indexer a = i_b } -> Type), 13 | (forall (a : A) (H : indexer (exp a) = i_b), P (existT _ (exp a) H)) -> 14 | forall (pa : { a : A & indexer a = i_b }), P (existT (fun a => indexer a = i_b) (exp (projT1 pa)) (coh i_b (projT1 pa) (projT2 pa))). 15 | Proof. 16 | intros i_b P pf pa. apply (pf (projT1 pa) (coh i_b (projT1 pa) (projT2 pa))). 17 | Defined. 18 | -------------------------------------------------------------------------------- /plugin/theories/Equivalences.v: -------------------------------------------------------------------------------- 1 | (* 2 | * This file contains useful generic equivalences that can be instantiated. 3 | *) 4 | 5 | (* 6 | * Useful equivalence for algebraic ornaments in packed form, like 7 | * { s : sigT (vector T) & projT1 s = n }. See coq/examples/Example.v for use 8 | * of this eliminator. 9 | *) 10 | Lemma unpack_generic (I_B : Type) (B : I_B -> Type): 11 | forall (i_b : I_B), { s : sigT B & projT1 s = i_b } -> B i_b. 12 | Proof. 13 | intros i_b ss. apply (@eq_rect _ (projT1 (projT1 ss)) _ (projT2 (projT1 ss)) i_b (projT2 ss)). 14 | Defined. 15 | 16 | Lemma unpack_generic_inv (I_B : Type) (B : I_B -> Type): 17 | forall (i_b : I_B), B i_b -> { s : sigT B & projT1 s = i_b }. 18 | Proof. 19 | intros i_b b. exists (existT _ i_b b). reflexivity. 20 | Defined. 21 | 22 | Lemma unpack_generic_section (I_B : Type) (B : I_B -> Type): 23 | forall i_b s, unpack_generic_inv I_B B i_b (unpack_generic I_B B i_b s) = s. 24 | Proof. 25 | intros. unfold unpack_generic, unpack_generic_inv. 26 | induction s. induction x. simpl in *. rewrite <- p. 27 | reflexivity. 28 | Defined. 29 | 30 | Lemma unpack_generic_retraction (I_B : Type) (B : I_B -> Type): 31 | forall i_b b, unpack_generic I_B B i_b (unpack_generic_inv I_B B i_b b) = b. 32 | Proof. 33 | intros. reflexivity. 34 | Defined. 35 | -------------------------------------------------------------------------------- /plugin/theories/Ornaments.v: -------------------------------------------------------------------------------- 1 | Require Ornamental.Adjoint. 2 | Require Ornamental.Unpack. 3 | Require Ornamental.Prod. 4 | Require Ornamental.Eliminators. 5 | Require Ornamental.Equivalences. 6 | 7 | Declare ML Module "ornaments". 8 | 9 | Export Ornamental.Eliminators. 10 | Export Ornamental.Equivalences. 11 | Export Ornamental.Unpack.Lemmas. 12 | Require Export Fixtranslation.Fixtoelim. 13 | -------------------------------------------------------------------------------- /plugin/theories/Prod.v: -------------------------------------------------------------------------------- 1 | Require Import Fixtranslation.Fixtoelim. 2 | 3 | Preprocess fst as fst. 4 | Preprocess snd as snd. 5 | -------------------------------------------------------------------------------- /plugin/theories/Unpack.v: -------------------------------------------------------------------------------- 1 | Require Import Coq.Program.Tactics. 2 | Require Import Coq.Logic.EqdepFacts. 3 | 4 | Local Notation "( x ; y )" := (@existT _ _ x y). 5 | Local Notation "p '.1'" := (@projT1 _ _ p) (left associativity, at level 8). 6 | Local Notation "p '.2'" := (@projT2 _ _ p) (left associativity, at level 8). 7 | 8 | Module Lemmas. 9 | 10 | (* Redefine transparent/reducible versions of these lemmas about dependent equality *) 11 | Definition eq_dep_eq_sigT_red (U : Type) (P : U -> Type) (p q : U) (x : P p) (y : P q) (H : eq_dep U P p x q y) : existT P p x = existT P q y := 12 | match H in (eq_dep _ _ _ _ q0 y0) return (existT P p x = existT P q0 y0) with 13 | | eq_dep_intro _ _ _ _ => eq_refl (existT P p x) 14 | end. 15 | 16 | Definition eq_sigT_eq_dep_red (U : Type) (P : U -> Type) (p q : U) (x : P p) (y : P q) (H : existT P p x = existT P q y) : eq_dep U P p x q y := 17 | @eq_ind_r _ 18 | (existT _ q y) 19 | (fun s => eq_dep U P (projT1 s) (projT2 s) q y) 20 | (eq_dep_intro U P q y) 21 | (existT _ p x) 22 | H. 23 | 24 | (* Also define our own two lemmas to handle typical side conditions. *) 25 | Lemma sigT_eta {A : Type} {B : A -> Type} (p : {x:A & B x}) : p = (p.1; p.2). 26 | Proof. destruct p. auto. Defined. 27 | 28 | Lemma eq_sigT_eta {A : Type} {B : A -> Type} {p q : {x:A & B x}} : 29 | p = q -> (p.1; p.2) = (q.1; q.2). 30 | Proof. destruct p, q. auto. Defined. 31 | 32 | End Lemmas. 33 | 34 | Import Lemmas. 35 | 36 | Ltac rewrap unwrapped := 37 | lazymatch goal with 38 | | [ |- forall (x : ?A), @?C x ] => 39 | let x := fresh x in 40 | refine (fun (x : ?A) => _); 41 | lazymatch A with 42 | | @sigT _ _ => 43 | rewrap (unwrapped x.1 x.2) 44 | | _ => 45 | rewrap (unwrapped x) 46 | end 47 | | [ |- @eq_dep ?A ?B ?x_i ?x ?y_i ?y ] => 48 | exact (@eq_dep_eq_sigT_red A B x_i y_i x y unwrapped) 49 | | [ |- _ ] => 50 | exact unwrapped 51 | end. 52 | 53 | Ltac unwrap wrapped := 54 | lazymatch (eval hnf in wrapped) with 55 | | forall (x : ?A), @?C x => 56 | let x := fresh x in 57 | lazymatch A with 58 | | @sigT ?A ?B => 59 | let x_i := fresh x "_i" in 60 | refine (forall (x_i : A) (x : B x_i), _); 61 | unwrap (C (x_i; x)) 62 | | _ => 63 | refine (forall (x : A), _); 64 | unwrap (C x) 65 | end 66 | | @eq (@sigT ?A ?B) ?x ?y => 67 | exact (eq_dep A B x.1 x.2 y.1 y.2) 68 | | _ => 69 | exact wrapped 70 | end. 71 | 72 | Ltac repack index value := 73 | lazymatch goal with 74 | | [ |- forall (x : ?A), _ ] => 75 | let x := fresh x in 76 | refine (fun (x : ?A) => _); 77 | lazymatch A with 78 | | @sigT _ _ => 79 | repack (index x.1 x.2) (value x.1 x.2) 80 | | _ => 81 | repack (index x) (value x) 82 | end 83 | | [ |- @sigT _ _ ] => 84 | exact (index; value) 85 | end. 86 | 87 | Ltac unpack_index packed := 88 | lazymatch (eval hnf in packed) with 89 | | forall (x : ?A), @?C x => 90 | let x := fresh x in 91 | lazymatch A with 92 | | @sigT ?A ?B => 93 | let x_i := fresh x "_i" in 94 | refine (forall (x_i : A) (x : B x_i), _); 95 | unpack_index (C (x_i; x)) 96 | | context K [(@sigT _ _)] => 97 | let A' := unwrap A in 98 | refine (forall (x : A'), _); 99 | assert A as x' by rewrap x; 100 | unpack_index (C x') 101 | | _ => 102 | refine (forall (x : A), _); 103 | unpack_index (C x) 104 | end 105 | | @sigT ?A ?B => 106 | exact A 107 | end. 108 | 109 | Ltac unpack_value packed index := 110 | lazymatch (eval hnf in packed) with 111 | | forall (x : ?A), @?C x => 112 | let x := fresh x in 113 | lazymatch A with 114 | | @sigT ?A ?B => 115 | let x_i := fresh x "_i" in 116 | refine (forall (x_i : A) (x : B x_i), _); 117 | unpack_value (C (x_i; x) (index x_i x)) 118 | | context K [(@sigT _ _)] => 119 | let A' := unwrap A in 120 | refine (forall (x : A'), _); 121 | assert A as x' by rewrap x; 122 | unpack_value (C x') (index x') 123 | | _ => 124 | refine (forall (x : A), _); 125 | unpack_value (C x) (index x) 126 | end 127 | | @sigT ?A ?B => 128 | exact (B index) 129 | end. 130 | 131 | Ltac unpack_type t := 132 | lazymatch (eval hnf in t) with 133 | | forall (x : @sigT ?A ?B), @?C x => 134 | let x := fresh x in 135 | let x_i := fresh x "_i" in 136 | refine (forall (x_i : A), _); 137 | refine (forall (x : B x_i), _); 138 | unpack_type (C (x_i; x)) 139 | | forall (x : ?A), @?C x => 140 | let x := fresh x in 141 | lazymatch A with 142 | | (@sigT ?A ?B) => 143 | let x_i := fresh x "_i" in 144 | refine (forall (x_i : A), _); 145 | refine (forall (x : B x_i), _); 146 | unpack_type (C (x_i; x)) 147 | | context K [forall _, sigT _ _] => 148 | let x_i := fresh x "_i" in 149 | let A' := unpack_index A in 150 | refine (forall (x_i : A), _); 151 | let B' := unpack_value A x_i in 152 | refine (forall (x : B' x_i), _); 153 | assert A as x' by repack x_i x; 154 | unpack_type (C x') 155 | | context K [forall (_ : sigT _ _), _] => 156 | let A' := unwrap A in 157 | refine (forall (x : A'), _); 158 | assert A as x' by rewrap x; 159 | unpack_type (C x') 160 | | _ => 161 | refine (forall (x : A), _); 162 | unpack_type (C x) 163 | end 164 | | @eq (@sigT ?A ?B) ?x ?y => 165 | exact (eq_dep A B x.1 x.2 y.1 y.2) 166 | | @sigT ?A ?B => 167 | refine (B ?[i]); 168 | unshelve (instantiate (i := _)) 169 | | _ => 170 | exact t 171 | end. 172 | 173 | (* Obviated by the below version but retained temporarily for debugging purposes. *) 174 | (* (* NOTE: The current type doesn't really need to be another argument... *) *) 175 | (* Ltac unpack_term e t := *) 176 | (* lazymatch (eval hnf in t) with *) 177 | (* | forall (x : @sigT ?A ?B), @?C x => *) 178 | (* let x := fresh x in *) 179 | (* let x_i := fresh x "_i" in *) 180 | (* refine (fun (x_i : A) (x : B x_i) => _); *) 181 | (* unpack_term (e (x_i; x)) (C (x_i; x)) *) 182 | (* | forall (x : ?A), @?C x => *) 183 | (* let x := fresh x in *) 184 | (* lazymatch A with *) 185 | (* | (@sigT ?A ?B) => *) 186 | (* let x_i := fresh x "_i" in *) 187 | (* refine (fun (x_i : A) => _); *) 188 | (* refine (fun (x : B x_i) => _); *) 189 | (* unpack_term (e (x_i; x)) (C (x_i; x)) *) 190 | (* | context K [forall _, sigT _ _] => *) 191 | (* let x_i := fresh x "_i" in *) 192 | (* let A' := unpack_index A in *) 193 | (* refine (fun (x_i : A) => _); *) 194 | (* let B' := unpack_value A x_i in *) 195 | (* refine (fun (x : B' x_i) => _); *) 196 | (* assert A as x' by repack x_i x; *) 197 | (* unpack_term (e x') (C x') *) 198 | (* | context K [forall (_ : sigT _ _), _] => *) 199 | (* let A' := unwrap A in *) 200 | (* refine (fun (x : A') => _); *) 201 | (* assert A as x' by rewrap x; *) 202 | (* unpack_term (e x') (C x') *) 203 | (* | _ => *) 204 | (* refine (fun (x : A) => _); *) 205 | (* unpack_term (e x) (C x) *) 206 | (* end *) 207 | (* | @eq (@sigT ?A ?B) ?x ?y => *) 208 | (* refine (eq_sigT_eq_dep_red A B x.1 y.1 x.2 y.2 (eq_sigT_eta e)) *) 209 | (* | @sigT ?A ?B => *) 210 | (* exact (e.2) *) 211 | (* | _ => *) 212 | (* exact e *) 213 | (* end. *) 214 | 215 | Ltac unpack e := 216 | let t := type of e in 217 | lazymatch eval hnf in t with 218 | | forall (x : @sigT ?A ?B), _ => 219 | let x := fresh x in 220 | let x_i := fresh x "_i" in 221 | refine (fun (x_i : A) (x : B x_i) => _); 222 | unpack (e (x_i; x)) 223 | | forall (x : ?A), _ => 224 | let x := fresh x in 225 | lazymatch A with 226 | | (@sigT ?A ?B) => 227 | let x_i := fresh x "_i" in 228 | refine (fun (x_i : A) => _); 229 | refine (fun (x : B x_i) => _); 230 | unpack (e (x_i; x)) 231 | | context K [forall _, sigT _ _] => 232 | let x_i := fresh x "_i" in 233 | let A' := unpack_index A in 234 | refine (fun (x_i : A) => _); 235 | let B' := unpack_value A x_i in 236 | refine (fun (x : B' x_i) => _); 237 | assert A as x' by repack x_i x; 238 | unpack (e x') 239 | | context K [forall (_ : sigT _ _), _] => 240 | let A' := unwrap A in 241 | refine (fun (x : A') => _); 242 | assert A as x' by rewrap x; 243 | unpack (e x') 244 | | _ => 245 | refine (fun (x : A) => _); 246 | unpack (e x) 247 | end 248 | | @eq (@sigT ?A ?B) ?x ?y => 249 | refine (eq_sigT_eq_dep_red A B x.1 y.1 x.2 y.2 (eq_sigT_eta e)) 250 | | @sigT ?A ?B => 251 | exact (e.2) 252 | | _ => 253 | exact e 254 | end. 255 | --------------------------------------------------------------------------------