From 832749ed3b4c15a3918d358ac7b06443affa17be Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 10:54:12 -0700 Subject: [PATCH 001/154] Add coq-plugin-lib to build script --- .gitmodules | 3 +++ README.md | 2 +- plugin/build.sh | 5 +++++ plugin/src/coq-plugin-lib | 1 + 4 files changed, 10 insertions(+), 1 deletion(-) create mode 100644 .gitmodules create mode 100755 plugin/build.sh create mode 160000 plugin/src/coq-plugin-lib diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..f3da973 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "plugin/src/coq-plugin-lib"] + path = plugin/src/coq-plugin-lib + url = https://github.com/uwplse/coq-plugin-lib.git diff --git a/README.md b/README.md index 89b0049..c03b38f 100644 --- a/README.md +++ b/README.md @@ -24,7 +24,7 @@ longer maintaining. ``` cd plugin -make +./build.sh ``` ## Using PUMPKIN diff --git a/plugin/build.sh b/plugin/build.sh new file mode 100755 index 0000000..23d8e49 --- /dev/null +++ b/plugin/build.sh @@ -0,0 +1,5 @@ +#!/usr/bin/env bash +git submodule init +git submodule update +coq_makefile -f _CoqProject -o Makefile +make clean && make && make install diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib new file mode 160000 index 0000000..a8bff19 --- /dev/null +++ b/plugin/src/coq-plugin-lib @@ -0,0 +1 @@ +Subproject commit a8bff1910868223b9117d242886a3020b4071c79 From 9d230333ca9e73c9521a84119f0561fc167addad Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 11:22:49 -0700 Subject: [PATCH 002/154] move utilities into coq-plugin-lib --- plugin/_CoqProject | 6 +- plugin/src/coq-plugin-lib | 2 +- plugin/src/library/utilities/utilities.ml | 199 --------------------- plugin/src/library/utilities/utilities.mli | 124 ------------- 4 files changed, 4 insertions(+), 327 deletions(-) delete mode 100644 plugin/src/library/utilities/utilities.ml delete mode 100644 plugin/src/library/utilities/utilities.mli diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 5bfe37a..255a029 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,4 +1,4 @@ --I src/library/utilities +-I src/coq-plugin-lib/src/utilities -I src/library/categories -I src/library/coq -I src/library/proofsearch/representation @@ -14,8 +14,8 @@ -R src Patcher -Q theories Patcher -src/library/utilities/utilities.mli -src/library/utilities/utilities.ml +src/coq-plugin-lib/src/utilities/utilities.mli +src/coq-plugin-lib/src/utilities/utilities.ml src/library/categories/category.mli src/library/categories/category.ml diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index a8bff19..16b2a15 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit a8bff1910868223b9117d242886a3020b4071c79 +Subproject commit 16b2a15ffe6a451b5f9d355033ccde44f72181f9 diff --git a/plugin/src/library/utilities/utilities.ml b/plugin/src/library/utilities/utilities.ml deleted file mode 100644 index 1399558..0000000 --- a/plugin/src/library/utilities/utilities.ml +++ /dev/null @@ -1,199 +0,0 @@ -open Util - -(* - * Basic utilities for collections, optionals, and so on - *) - -(* --- Optionals --- *) - -(* This should be in the standard library, but isn't bound for some reason *) -let map_default f default x = - if Option.has_some x then f (Option.get x) else default - -(* --- Lists --- *) - -(* Get the last element of a list *) -let last (l : 'a list) : 'a = - List.hd (List.rev l) - -(* Get all but the last element of a list *) -let all_but_last (l : 'a list) : 'a list = - List.rev (List.tl (List.rev l)) - -(* Snoc *) -let snoc (a : 'a) (l : 'a list) : 'a list = - List.append l [a] - -(* Take n elements of a list *) -let rec take (i : int) (l : 'a list) : 'a list = - if i = 0 then - [] - else - match l with - | [] -> - [] - | h :: tl -> - h :: (take (i - 1) tl) - -(* Take all but n elements of a list *) -let take_except (i : int) (l : 'a list) : 'a list = - take (List.length l - i) l - -(* Like take, but return the remainder too *) -let rec take_split (i : int) (l : 'a list) : ('a list * 'a list) = - if i = 0 then - ([], l) - else - match l with - | [] -> - ([], []) - | h :: tl -> - let (before, after) = take_split (i - 1) tl in - (h :: before, after) - -(* - * Remove duplicates from a list - *) -let rec unique (eq : 'a -> 'a -> bool) (l : 'a list) : 'a list = - match l with - | [] -> [] - | h :: t -> h :: (List.filter (fun a -> not (eq h a)) (unique eq t)) - -(* - * Map a function over a list, then flatten the result - *) -let flat_map (f : 'a -> 'b list) (l : 'a list) : 'b list = - List.flatten (List.map f l) - -(* - * Return true if a list has length > 0 - *) -let non_empty (l : 'a list) : bool = - List.length l > 0 - -(* - * Returns the offset of an element that satisfies p in a - *) -let find_off (a : 'a list) (p : 'a -> bool) : int = - let rec find_rec a p n = - match a with - | [] -> failwith "not found" - | h :: tl -> - if p h then - n - else - find_rec tl p (n + 1) - in find_rec a p 0 - -(* - * All combinations of elements in a list - *) -let rec combinations (l : 'a list) = - match l with - | [] -> [] - | h :: t -> List.append (List.map (fun e -> (h, e)) t) (combinations t) - -(* - * Cartesian product of two lists - * From http://stackoverflow.com/questions/1507496/ocaml-permutation-of-every-value-in-two-sets-how-to-translate-this-from-java - *) -let cartesian (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list = - List.concat (List.map (fun a -> List.map (fun b -> (a, b)) l2) l1) - -(* - * Combine all permutations of pairs of elements in lists l1 and l2 via f - *) -let combine_cartesian (f : 'a -> 'b -> 'c) (l1 : 'a list) (l2 : 'b list) : 'c list = - List.map (fun (a, b) -> f a b) (cartesian l1 l2) - -(* - * Turns an array of lists into a list of arrays - *) -let combine_cartesian_append (al : 'a list array) : 'a array list = - let al' = Array.to_list (Array.map (List.map (fun a -> [a])) al) in - if (Array.length al) <= 1 then - List.map Array.of_list (List.concat al') - else - List.map Array.of_list (List.fold_left (combine_cartesian List.append) (List.hd al') (List.tl al')) - - -(* Map3 *) -let rec map3 (f : 'a -> 'b -> 'c -> 'd) l1 l2 l3 : 'd list = - match (l1, l2, l3) with - | ([], [], []) -> - [] - | (h1 :: t1, h2 :: t2, h3 :: t3) -> - let r = f h1 h2 h3 in r :: map3 f t1 t2 t3 - -(* - * Creates a list of the range of min to max, excluding max - * This is an auxiliary function renamed from seq in template-coq - *) -let rec range (min : int) (max : int) : int list = - if min < max then - min :: range (min + 1) max - else - [] - -(* Creates a list from the index 1 to max, inclusive *) -let from_one_to (max : int) : int list = - range 1 (max + 1) - -(* - * This is an auxiliary function from StackOverflow - * Splits a list at an index - *) -let rec split_at (n : int) (l : 'a list) : (('a list) * ('a list)) = - if n = 0 then - ([], l) - else - match l with - h :: t -> - let (l1, l2) = split_at (n - 1) t in - (h :: l1, l2) - | [] -> - ([], []) - -(* --- Tuples --- *) - -(* Map f over a tuple *) -let map_tuple (f : 'a -> 'b) ((a1, a2) : ('a * 'a)) : ('b * 'b) = - (f a1, f a2) - -(* Fold f over a tuple *) -let fold_tuple (f : 'a -> 'b -> 'c) ((a, b) : ('a * 'b)) : 'c = - f a b - -(* --- Propositions --- *) - -(* Always true *) -let always_true _ = true - -(* --- Control structures --- *) - -let map_if_else f g b x = if b then f x else g x -let map_if f b x = map_if_else f (fun a -> a) b x - -(* --- Functions --- *) - -(* Flip the first and second parameters of a function. *) -let flip f = fun x y -> f y x - -(* --- Common helper functions --- *) - -(* - * The identity function - *) -let id (a : 'a) = - a - -(* Constant ID *) -let k_fresh = ref (1) - -(* - * Get a fresh constant identifier - *) -let fid () : int = - let id = !k_fresh in - k_fresh := id + 1; - id diff --git a/plugin/src/library/utilities/utilities.mli b/plugin/src/library/utilities/utilities.mli deleted file mode 100644 index a31b225..0000000 --- a/plugin/src/library/utilities/utilities.mli +++ /dev/null @@ -1,124 +0,0 @@ -(* - * Basic utilities for collections, optionals, and so on - *) - -(* --- Optionals --- *) - -(* - * Map a function on an optional, and return a default value if it's none - * This should be in the standard library, but for some reason locally is not - *) -val map_default : ('a -> 'b) -> 'b -> 'a option -> 'b - -(* --- Lists --- *) - -val last : 'a list -> 'a -val all_but_last : 'a list -> 'a list -val snoc : 'a -> 'a list -> 'a list -val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list - -(* - * Take n elements of a list - *) -val take : int -> 'a list -> 'a list - -(* - * Take all but n elements of a list - *) -val take_except : int -> 'a list -> 'a list - -(* - * Split a list l into (l1, l2) where |l1| = n and |l2| = |l| - n - *) -val take_split : int -> 'a list -> ('a list * 'a list) - -(* - * Remove duplicates from a list - *) -val unique : ('a -> 'a -> bool) -> 'a list -> 'a list - -(* - * Map a function over a list, then flatten the result - *) -val flat_map : ('a -> 'b list) -> 'a list -> 'b list - -(* - * Return true if a list has length > 0 - *) -val non_empty : 'a list -> bool - -(* - * Return the offset of an element that satisfies p in a - * Fail if the element is not in the list - *) -val find_off : 'a list -> ('a -> bool) -> int - -(* - * All combinations of elements in a list - *) -val combinations : 'a list -> ('a * 'a) list - -(* - * Cartesian product of two lists - *) -val cartesian : 'a list -> 'b list -> ('a * 'b) list - -(* - * Combine all permutations of pairs of elements in two lists - * Use some combinator function to combine them - *) -val combine_cartesian : ('a -> 'b -> 'c) -> 'a list -> 'b list -> 'c list - -(* - * Turns an array of lists [[t11, t12] [t21, t22] ..] into a list - * of arrays [[t11 t21 ..] .. [t11 t22 ..] .. [t12 t21 ..] .. [t12 t22 ..] ..] - *) -val combine_cartesian_append : 'a list array -> 'a array list - -(* - * [min, max) - *) -val range : int -> int -> int list - -(* - * [1, max] - *) -val from_one_to : int -> int list - -(* - * Splits a list at an index into two lists - *) -val split_at : int -> 'a list -> (('a list) * ('a list)) - -(* --- Tuples --- *) - -val map_tuple : ('a -> 'b) -> ('a * 'a) -> ('b * 'b) -val fold_tuple : ('a -> 'b -> 'c) -> ('a * 'b) -> 'c - -(* --- Propositions --- *) - -val always_true : 'a -> bool - -(* --- Control structures --- *) - -val map_if_else : ('a -> 'b) -> ('a -> 'b) -> bool -> 'a -> 'b -val map_if : ('a -> 'a) -> bool -> 'a -> 'a - -(* --- Functions --- *) - -(* - * Flip the first and second parameters of a function. - *) -val flip : ('a -> 'b -> 'c) -> ('b -> 'a -> 'c) - -(* --- Common helper functions --- *) - -(* - * The identity function - *) -val id : 'a -> 'a - -(* - * Get a fresh constant identifier - *) -val fid : unit -> int From 80d99a2ccf32ea2e00547b33c4a97b233adb060e Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 11:30:57 -0700 Subject: [PATCH 003/154] Move category code outside of library, since it will be removed later --- plugin/_CoqProject | 4 ++-- plugin/src/{library => }/categories/category.ml | 0 plugin/src/{library => }/categories/category.mli | 0 3 files changed, 2 insertions(+), 2 deletions(-) rename plugin/src/{library => }/categories/category.ml (100%) rename plugin/src/{library => }/categories/category.mli (100%) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 255a029..52a98c0 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -17,8 +17,8 @@ src/coq-plugin-lib/src/utilities/utilities.mli src/coq-plugin-lib/src/utilities/utilities.ml -src/library/categories/category.mli -src/library/categories/category.ml +src/categories/category.mli +src/categories/category.ml src/library/coq/coqterms.mli src/library/coq/coqterms.ml diff --git a/plugin/src/library/categories/category.ml b/plugin/src/categories/category.ml similarity index 100% rename from plugin/src/library/categories/category.ml rename to plugin/src/categories/category.ml diff --git a/plugin/src/library/categories/category.mli b/plugin/src/categories/category.mli similarity index 100% rename from plugin/src/library/categories/category.mli rename to plugin/src/categories/category.mli From 22f057a67a22524b1bba22eb1ff522f59e484cb9 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 11:45:33 -0700 Subject: [PATCH 004/154] Move coq functions into library --- plugin/_CoqProject | 30 +- plugin/src/coq-plugin-lib | 2 +- plugin/src/library/coq/coqterms.ml | 848 ------------------------ plugin/src/library/coq/coqterms.mli | 338 ---------- plugin/src/library/coq/debruijn.ml | 97 --- plugin/src/library/coq/debruijn.mli | 53 -- plugin/src/library/coq/filters.ml | 51 -- plugin/src/library/coq/filters.mli | 20 - plugin/src/library/coq/hofs.ml | 495 -------------- plugin/src/library/coq/hofs.mli | 149 ----- plugin/src/library/coq/printing.ml | 184 ----- plugin/src/library/coq/printing.mli | 43 -- plugin/src/library/coq/reducers.ml | 117 ---- plugin/src/library/coq/reducers.mli | 75 --- plugin/src/library/coq/substitution.ml | 85 --- plugin/src/library/coq/substitution.mli | 58 -- plugin/src/patch.mlpack | 4 +- 17 files changed, 18 insertions(+), 2631 deletions(-) delete mode 100644 plugin/src/library/coq/coqterms.ml delete mode 100644 plugin/src/library/coq/coqterms.mli delete mode 100644 plugin/src/library/coq/debruijn.ml delete mode 100644 plugin/src/library/coq/debruijn.mli delete mode 100644 plugin/src/library/coq/filters.ml delete mode 100644 plugin/src/library/coq/filters.mli delete mode 100644 plugin/src/library/coq/hofs.ml delete mode 100644 plugin/src/library/coq/hofs.mli delete mode 100644 plugin/src/library/coq/printing.ml delete mode 100644 plugin/src/library/coq/printing.mli delete mode 100644 plugin/src/library/coq/reducers.ml delete mode 100644 plugin/src/library/coq/reducers.mli delete mode 100644 plugin/src/library/coq/substitution.ml delete mode 100644 plugin/src/library/coq/substitution.mli diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 52a98c0..4071b86 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -17,24 +17,24 @@ src/coq-plugin-lib/src/utilities/utilities.mli src/coq-plugin-lib/src/utilities/utilities.ml +src/coq-plugin-lib/src/coq/coqterms.mli +src/coq-plugin-lib/src/coq/coqterms.ml +src/coq-plugin-lib/src/coq/printing.mli +src/coq-plugin-lib/src/coq/printing.ml +src/coq-plugin-lib/src/coq/hofs.mli +src/coq-plugin-lib/src/coq/hofs.ml +src/coq-plugin-lib/src/coq/debruijn.mli +src/coq-plugin-lib/src/coq/debruijn.ml +src/coq-plugin-lib/src/coq/substitution.mli +src/coq-plugin-lib/src/coq/substitution.ml +src/coq-plugin-lib/src/coq/filters.mli +src/coq-plugin-lib/src/coq/filters.ml +src/coq-plugin-lib/src/coq/reducers.mli +src/coq-plugin-lib/src/coq/reducers.ml + src/categories/category.mli src/categories/category.ml -src/library/coq/coqterms.mli -src/library/coq/coqterms.ml -src/library/coq/printing.mli -src/library/coq/printing.ml -src/library/coq/hofs.mli -src/library/coq/hofs.ml -src/library/coq/debruijn.mli -src/library/coq/debruijn.ml -src/library/coq/substitution.mli -src/library/coq/substitution.ml -src/library/coq/filters.mli -src/library/coq/filters.ml -src/library/coq/reducers.mli -src/library/coq/reducers.ml - src/library/proofsearch/representation/candidates.mli src/library/proofsearch/representation/candidates.ml src/library/proofsearch/representation/assumptions.mli diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 16b2a15..9d7169a 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 16b2a15ffe6a451b5f9d355033ccde44f72181f9 +Subproject commit 9d7169a92d7b04318f914cc51293c86407d9c8aa diff --git a/plugin/src/library/coq/coqterms.ml b/plugin/src/library/coq/coqterms.ml deleted file mode 100644 index 111dd98..0000000 --- a/plugin/src/library/coq/coqterms.ml +++ /dev/null @@ -1,848 +0,0 @@ -(* - * Coq term and environment management - *) - -open Util -open Context -open Environ -open Constr -open Names -open Constrexpr -open Evd -open Utilities -open Declarations -open Decl_kinds -open Constrextern - -module Globmap = Globnames.Refmap -module Globset = Globnames.Refset - -module CRD = Context.Rel.Declaration - -(* - * Note: This will clean up significantly when we merge DEVOID and PUMPKIN, - * and split back into multiple files. We'll also use better evar map and - * universe hygiene at that point. - *) - -(* --- Auxiliary types --- *) - -type closure = env * (types list) - -(* --- Constants --- *) - -let coq_init_logic = - ModPath.MPfile - (DirPath.make (List.map Id.of_string ["Logic"; "Init"; "Coq"])) - -let coq_init_datatypes = - ModPath.MPfile - (DirPath.make (List.map Id.of_string ["Datatypes"; "Init"; "Coq"])) - -(* Symmetric eliminator for equality *) -let eq_ind_r : types = - mkConst (Constant.make2 coq_init_logic (Label.make "eq_ind_r")) - -(* Eliminator for equality *) -let eq_ind : types = - mkConst (Constant.make2 coq_init_logic (Label.make "eq_ind")) - -(* Symmetric eleiminator for equality into type *) -let eq_rec_r : types = - mkConst (Constant.make2 coq_init_logic (Label.make "eq_rec_r")) - -(* Eliminator for equality into type *) -let eq_rec : types = - mkConst (Constant.make2 coq_init_logic (Label.make "eq_rec")) - -(* Symmetry *) -let eq_sym : types = - mkConst (Constant.make2 coq_init_logic (Label.make "eq_sym")) - -(* The identity proposition *) -let id_prop : types = - mkConst (Constant.make2 coq_init_datatypes (Label.make "idProp")) - -(* The identity type *) -let id_typ : types = - mkConst (Constant.make2 coq_init_datatypes (Label.make "id")) - -(* --- Questions about constants --- *) - -(* Determine if a term applies an identity term *) -let applies_identity (trm : types) : bool = - match kind trm with - | App (f, _) -> - equal f id_prop || equal f id_typ - | _ -> - false - -(* - * Check if a term is a rewrite via eq_ind or eq_ind_r - * For efficiency, just check syntactic equality - * Don't consider convertible terms for now - *) -let is_rewrite (trm : types) : bool = - let eq_term = equal trm in - eq_term eq_ind_r || eq_term eq_ind || eq_term eq_rec_r || eq_term eq_rec - -(* --- Convenient applications of constants --- *) - -(* Get the Coq identity term for typ *) -let identity_term (env : env) (typ : types) : types = - let id = mkApp (id_prop, Array.make 1 typ) in - try - let _ = Typeops.infer env id in id - with _ -> mkApp (id_typ, Array.make 1 typ) - -(* --- Representations --- *) - -(* Intern a term (for now, ignore the resulting evar_map) *) -let intern env evd t : types = - let (trm, _) = Constrintern.interp_constr env evd t in - EConstr.to_constr evd trm - -(* Extern a term *) -let extern env evd t : constr_expr = - Constrextern.extern_constr true env evd (EConstr.of_constr t) - -(* https://github.com/ybertot/plugin_tutorials/blob/master/tuto1/src/simple_declare.ml *) -let edeclare ident (_, poly, _ as k) ~opaque sigma udecl body tyopt imps hook refresh = - let open EConstr in - (* XXX: "Standard" term construction combinators such as `mkApp` - don't add any universe constraints that may be needed later for - the kernel to check that the term is correct. - - We could manually call `Evd.add_universe_constraints` - [high-level] or `Evd.add_constraints` [low-level]; however, that - turns out to be a bit heavyweight. - - Instead, we call type inference on the manually-built term which - will happily infer the constraint for us, even if that's way more - costly in term of CPU cycles. - - Beware that `type_of` will perform full type inference including - canonical structure resolution and what not. - *) - let env = Global.env () in - let sigma = - if refresh then - fst (Typing.type_of ~refresh:false env sigma body) - else - sigma - in - let sigma = Evd.minimize_universes sigma in - let body = to_constr sigma body in - let tyopt = Option.map (to_constr sigma) tyopt in - let uvars_fold uvars c = - Univ.LSet.union uvars (Univops.universes_of_constr env c) in - let uvars = List.fold_left uvars_fold Univ.LSet.empty - (Option.List.cons tyopt [body]) in - let sigma = Evd.restrict_universe_context sigma uvars in - let univs = Evd.check_univ_decl ~poly sigma udecl in - let ubinders = Evd.universe_binders sigma in - let ce = Declare.definition_entry ?types:tyopt ~univs body in - DeclareDef.declare_definition ident k ce ubinders imps hook - -(* Define a new Coq term *) -let define_term ?typ (n : Id.t) (evm : evar_map) (trm : types) (refresh : bool) = - let k = (Global, Flags.is_universe_polymorphism(), Definition) in - let udecl = Univdecls.default_univ_decl in - let nohook = Lemmas.mk_hook (fun _ x -> x) in - let etrm = EConstr.of_constr trm in - let etyp = Option.map EConstr.of_constr typ in - edeclare n k ~opaque:false evm udecl etrm etyp [] nohook refresh - -(* --- Application and arguments --- *) - -(* Get a list of all arguments, fully unfolded at the head *) -let unfold_args_app trm = - let (f, args) = destApp trm in - let rec unfold trm = - match kind trm with - | App (f, args) -> - List.append (unfold f) (Array.to_list args) - | _ -> - [trm] - in List.append (List.tl (unfold f)) (Array.to_list args) - -(* Like unfold_args_app, but return empty if it's not an application *) -let unfold_args trm = - if isApp trm then unfold_args_app trm else [] - -(* Get the last argument of an application *) -let last_arg trm = - if isApp trm then last (unfold_args trm) else failwith "not an application" - -(* Get the first function of an application *) -let rec first_fun t = - match kind t with - | App (f, args) -> - first_fun f - | _ -> - t - -(* - * Get the argument to an application of a property at argument position i - * This unfolds all arguments first - *) -let get_arg i trm = - match kind trm with - | App (_, _) -> - let args = Array.of_list (unfold_args trm) in - Array.get args i - | _ -> - failwith "not an application" - -(* --- Constructing terms --- *) - -(* mkApp with a list *) -let mkAppl (f, args) = mkApp (f, Array.of_list args) - -(* Recursively turn a product into a function *) -let rec prod_to_lambda trm = - match kind trm with - | Prod (n, t, b) -> - mkLambda (n, t, prod_to_lambda b) - | _ -> - trm - -(* Recursively turn a function into a product *) -let rec lambda_to_prod trm = - match kind trm with - | Lambda (n, t, b) -> - mkProd (n, t, lambda_to_prod b) - | _ -> - trm - -(* --- Convertibility, reduction, and types --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = - let jmt = Typeops.infer env trm in - j_type jmt - -(* Safely infer the WHNF type of a term, updating the evar map *) -let e_infer_type env evm term = - EConstr.of_constr term |> Typing.e_type_of ~refresh:true env evm |> - Reductionops.whd_all env !evm |> EConstr.to_constr !evm - -(* Safely infer the sort of a type, updating the evar map *) -let e_infer_sort env evm term = - EConstr.of_constr term |> Typing.e_sort_of env evm |> Sorts.family - -(* Safely instantiate a global reference, with proper universe handling *) -let e_new_global evm gref = - Evarutil.e_new_global evm gref |> EConstr.to_constr !evm - -(* Check whether two terms are convertible, ignoring universe inconsistency *) -let conv_ignoring_univ_inconsistency env evm (trm1 : types) (trm2 : types) : bool = - match map_tuple kind (trm1, trm2) with - | (Sort (Type u1), Sort (Type u2)) -> - (* PUMPKIN assumes universe consistency for now *) - true - | _ -> - let etrm1 = EConstr.of_constr trm1 in - let etrm2 = EConstr.of_constr trm2 in - try - Reductionops.is_conv env evm etrm1 etrm2 - with _ -> - false - -(* Checks whether two terms are convertible in env with no evars *) -let convertible (env : env) (evd : evar_map) (trm1 : types) (trm2 : types) : bool = - conv_ignoring_univ_inconsistency env evd trm1 trm2 - -(* - * Checks whether the conclusions of two dependent types are convertible, - * modulo the assumption that every argument we encounter is equal when - * the types of those arguments are convertible. Expect exactly the same - * number of arguments in the same order. - *) -let rec concls_convertible (env : env) (evd : evar_map) (typ1 : types) (typ2 : types) : bool = - match (kind typ1, kind typ2) with - | (Prod (n1, t1, b1), Prod (n2, t2, b2)) -> - if convertible env evd t1 t2 then - concls_convertible (push_rel CRD.(LocalAssum(n1, t1)) env) evd b1 b2 - else - false - | _ -> - convertible env evd typ1 typ2 - -(* Check whether a term has a given type *) -let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool = - try - let trm_typ = infer_type env evd trm in - convertible env evd trm_typ typ - with _ -> false - -(* Default reducer *) -let reduce_term (env : env) (trm : types) : types = - EConstr.to_constr - Evd.empty - (Reductionops.nf_betaiotazeta env Evd.empty (EConstr.of_constr trm)) - -(* Delta reduction *) -let delta (env : env) (trm : types) = - EConstr.to_constr - Evd.empty - (Reductionops.whd_delta env Evd.empty (EConstr.of_constr trm)) - -(* - * There's a part of the env that has opacity info, - * so if you want to make some things opaque, can add them - * get env, store it, call set_strategy w/ opaque, - * then revert later - * - * See environ.mli - * set_oracle - * set_strategy - *) - -(* nf_all *) -let reduce_nf (env : env) (trm : types) : types = - EConstr.to_constr - Evd.empty - (Reductionops.nf_all env Evd.empty (EConstr.of_constr trm)) - -(* Reduce the type *) -let reduce_type (env : env) evd (trm : types) : types = - reduce_term env (infer_type env evd trm) - -(* Chain reduction *) -let chain_reduce rg rf (env : env) (trm : types) : types = - rg env (rf env trm) - -(* Apply on types instead of on terms *) -let on_type f env evd trm = - f (reduce_type env evd trm) - -(* Checks whether the types of two terms are convertible *) -let types_convertible (env : env) (evd : evar_map) (trm1 : types) (trm2 : types) : bool = - try - let typ1 = infer_type env evd trm1 in - let typ2 = infer_type env evd trm2 in - convertible env evd typ1 typ2 - with _ -> false - -(* --- Environments --- *) - -(* Look up all indexes from is in env *) -let lookup_rels (is : int list) (env : env) : CRD.t list = - List.map (fun i -> lookup_rel i env) is - -(* Return a list of all indexes in env, starting with 1 *) -let all_rel_indexes (env : env) : int list = - from_one_to (nb_rel env) - -(* Return a list of all bindings in env, starting with the closest *) -let lookup_all_rels (env : env) : CRD.t list = - lookup_rels (all_rel_indexes env) env - -(* Push a local binding to an environment *) -let push_local (n, t) = push_rel CRD.(LocalAssum (n, t)) - -(* Push a let-in definition to an environment *) -let push_let_in (n, e, t) = push_rel CRD.(LocalDef(n, e, t)) - -(* Is the rel declaration a local assumption? *) -let is_rel_assum = Rel.Declaration.is_local_assum - -(* Is the rel declaration a local definition? *) -let is_rel_defin = Rel.Declaration.is_local_def - -(* Make the rel declaration for a local assumption *) -let rel_assum (name, typ) = - Rel.Declaration.LocalAssum (name, typ) - -(* Make the rel declaration for a local definition *) -let rel_defin (name, def, typ) = - Rel.Declaration.LocalDef (name, def, typ) - -(* Get the name of a rel declaration *) -let rel_name decl = - Rel.Declaration.get_name decl - -(* Get the optional value of a rel declaration *) -let rel_value decl = - Rel.Declaration.get_value decl - -(* Get the type of a rel declaration *) -let rel_type decl = - Rel.Declaration.get_type decl - -(* Map over a rel context with environment kept in synch *) -let map_rel_context env make ctxt = - Rel.fold_outside - (fun decl (env, res) -> - push_rel decl env, (make env decl) :: res) - ctxt - ~init:(env, []) |> - snd - -(* - * Bind all local declarations in the relative context onto the body term as - * products, substituting away (i.e., zeta-reducing) any local definitions. - *) -let smash_prod_assum ctxt body = - Rel.fold_inside - (fun body decl -> - match rel_value decl with - | Some defn -> Vars.subst1 defn body - | None -> mkProd (rel_name decl, rel_type decl, body)) - ~init:body - ctxt - -(* - * Bind all local declarations in the relative context onto the body term as - * lambdas, substituting away (i.e., zeta-reducing) any local definitions. - *) -let smash_lam_assum ctxt body = - Rel.fold_inside - (fun body decl -> - match rel_value decl with - | Some defn -> Vars.subst1 defn body - | None -> mkLambda (rel_name decl, rel_type decl, body)) - ~init:body - ctxt - -(* - * Decompose the first n product bindings, zeta-reducing let bindings to reveal - * further product bindings when necessary. - *) -let decompose_prod_n_zeta n term = - assert (n >= 0); - let rec aux n ctxt body = - if n > 0 then - match Constr.kind body with - | Prod (name, param, body) -> - aux (n - 1) (Rel.add (rel_assum (name, param)) ctxt) body - | LetIn (name, def_term, def_type, body) -> - aux n ctxt (Vars.subst1 def_term body) - | _ -> - invalid_arg "decompose_prod_n_zeta: not enough products" - else - ctxt, body - in - aux n Rel.empty term - -(* - * Decompose the first n lambda bindings, zeta-reducing let bindings to reveal - * further lambda bindings when necessary. - *) -let decompose_lam_n_zeta n term = - assert (n >= 0); - let rec aux n ctxt body = - if n > 0 then - match Constr.kind body with - | Lambda (name, param, body) -> - aux (n - 1) (Rel.add (rel_assum (name, param)) ctxt) body - | LetIn (name, def_term, def_type, body) -> - Vars.subst1 def_term body |> aux n ctxt - | _ -> - invalid_arg "decompose_lam_n_zeta: not enough lambdas" - else - ctxt, body - in - aux n Rel.empty term - -(* Lookup n rels and remove then *) -let lookup_pop (n : int) (env : env) = - let rels = List.map (fun i -> lookup_rel i env) (from_one_to n) in - (pop_rel_context n env, rels) - -let force_constant_body const_body = - match const_body.const_body with - | Def const_def -> - Mod_subst.force_constr const_def - | OpaqueDef opaq -> - Opaqueproof.force_proof (Global.opaque_tables ()) opaq - | _ -> - CErrors.user_err ~hdr:"force_constant_body" - (Pp.str "An axiom has no defining term") - -(* Lookup a definition *) -let lookup_definition (env : env) (def : types) : types = - match kind def with - | Const (c, u) -> force_constant_body (lookup_constant c env) - | Ind _ -> def - | _ -> failwith "not a definition" - -(* Fully lookup a def in env, but return the term if it is not a definition *) -let rec unwrap_definition (env : env) (trm : types) : types = - try - unwrap_definition env (lookup_definition env trm) - with _ -> - trm - -(* Get the type of an inductive type *) -let type_of_inductive env index mutind_body : types = - let ind_bodies = mutind_body.mind_packets in - let ind_body = Array.get ind_bodies index in - let univs = Declareops.inductive_polymorphic_context mutind_body in - let univ_instance = Univ.make_abstract_instance univs in - let mutind_spec = (mutind_body, ind_body) in - Inductive.type_of_inductive env (mutind_spec, univ_instance) - -(* - * Inductive types create bindings that we need to push to the environment - * This function gets those bindings - *) -let bindings_for_inductive env mutind_body ind_bodies : CRD.t list = - Array.to_list - (Array.mapi - (fun i ind_body -> - let name_id = ind_body.mind_typename in - let typ = type_of_inductive env i mutind_body in - CRD.LocalAssum (Name name_id, typ)) - ind_bodies) - -(* - * Similarly but for fixpoints - *) -let bindings_for_fix (names : name array) (typs : types array) : CRD.t list = - Array.to_list - (CArray.map2_i - (fun i name typ -> CRD.LocalAssum (name, Vars.lift i typ)) - names typs) - -(* Bind the declarations of a local context as product/let-in bindings *) -let recompose_prod_assum decls term = - let bind term decl = Term.mkProd_or_LetIn decl term in - Rel.fold_inside bind ~init:term decls - -(* Bind the declarations of a local context as lambda/let-in bindings *) -let recompose_lam_assum decls term = - let bind term decl = Term.mkLambda_or_LetIn decl term in - Rel.fold_inside bind ~init:term decls - -(* Instantiate an abstract universe context *) -let inst_abs_univ_ctx abs_univ_ctx = - (* Note that we're creating *globally* fresh universe levels. *) - Universes.fresh_instance_from_context abs_univ_ctx |> Univ.UContext.make - -(* --- Basic questions about terms --- *) - -(* Is the first term equal to a "head" (application prefix) of the second? - * The notion of term equality is syntactic (i.e., no environment) and defaults - * to syntactic equality modulo alpha, casts, grouping, and universes. The - * result of this function is an informative boolean: an optional array, with - * None meaning false and Some meaning true and giving the trailing arguments. - * - * This function is similar to is_or_applies, except for term equality and the - * informative boolean result. - *) -let eq_constr_head ?(eq_constr=eq_constr_nounivs) term term' = - let head, args = decompose_app term in - let head', args' = decompose_app term' in - if eq_constr head head' && List.prefix_of eq_constr args args' then - Some (List.skipn (List.length args) args' |> Array.of_list) - else - None - -(* --- Inductive types and their eliminators --- *) - -(* Don't support mutually inductive or coinductive types yet *) -let check_inductive_supported mutind_body : unit = - let ind_bodies = mutind_body.mind_packets in - if Array.length ind_bodies > 1 then - CErrors.user_err (Pp.str "Mutually inductive types are not supported") - else if (mutind_body.mind_finite = Declarations.CoFinite) then - CErrors.user_err (Pp.str "Coinductive types are not supported") - -(* - * Check if a constant is an inductive elminator - * If so, return the inductive type - *) -let inductive_of_elim (env : env) (pc : pconstant) : mutual_inductive option = - let (c, u) = pc in - let kn = Constant.canonical c in - let (modpath, dirpath, label) = KerName.repr kn in - let rec try_find_ind is_rev = - try - let label_string = Label.to_string label in - let label_length = String.length label_string in - let split_index = String.rindex_from label_string (if is_rev then (label_length - 3) else label_length) '_' in - let suffix_length = label_length - split_index in - let suffix = String.sub label_string split_index suffix_length in - if (suffix = "_ind" || suffix = "_rect" || suffix = "_rec" || suffix = "_ind_r") then - let ind_label_string = String.sub label_string 0 split_index in - let ind_label = Label.of_id (Id.of_string_soft ind_label_string) in - let ind_name = MutInd.make1 (KerName.make modpath dirpath ind_label) in - lookup_mind ind_name env; - Some ind_name - else - if not is_rev then - try_find_ind true - else - None - with _ -> - if not is_rev then - try_find_ind true - else - None - in try_find_ind false - -(* - * Get the number of constructors for an inductive type - * - * When we implement mutually inductive types, we may need to - * update this heuristic. - *) -let num_constrs (mutind_body : mutual_inductive_body) : int = - Array.fold_left - (fun n i -> - n + (Array.length i.mind_consnames)) - 0 - mutind_body.mind_packets - -(* Determine whether template polymorphism is used for a one_inductive_body *) -let is_ind_body_template ind_body = - match ind_body.mind_arity with - | RegularArity _ -> false - | TemplateArity _ -> true - -(* Construct the arity of an inductive type from a one_inductive_body *) -let arity_of_ind_body ind_body = - match ind_body.mind_arity with - | RegularArity { mind_user_arity; mind_sort } -> - mind_user_arity - | TemplateArity { template_param_levels; template_level } -> - let sort = Constr.mkType template_level in - recompose_prod_assum ind_body.mind_arity_ctxt sort - -(* Create an Entries.local_entry from a Rel.Declaration.t *) -let make_ind_local_entry decl = - let entry = - match decl with - | CRD.LocalAssum (_, typ) -> Entries.LocalAssumEntry typ - | CRD.LocalDef (_, term, _) -> Entries.LocalDefEntry term - in - match CRD.get_name decl with - | Name.Name id -> (id, entry) - | Name.Anonymous -> failwith "Parameters to an inductive type may not be anonymous" - -(* Instantiate an abstract_inductive_universes into an Entries.inductive_universes with Univ.UContext.t *) -let make_ind_univs_entry = function - | Monomorphic_ind univ_ctx_set -> - let univ_ctx = Univ.UContext.empty in - (Entries.Monomorphic_ind_entry univ_ctx_set, univ_ctx) - | Polymorphic_ind abs_univ_ctx -> - let univ_ctx = inst_abs_univ_ctx abs_univ_ctx in - (Entries.Polymorphic_ind_entry univ_ctx, univ_ctx) - | Cumulative_ind abs_univ_cumul -> - let abs_univ_ctx = Univ.ACumulativityInfo.univ_context abs_univ_cumul in - let univ_ctx = inst_abs_univ_ctx abs_univ_ctx in - let univ_var = Univ.ACumulativityInfo.variance abs_univ_cumul in - let univ_cumul = Univ.CumulativityInfo.make (univ_ctx, univ_var) in - (Entries.Cumulative_ind_entry univ_cumul, univ_ctx) - -let open_inductive ?(global=false) env (mind_body, ind_body) = - let univs, univ_ctx = make_ind_univs_entry mind_body.mind_universes in - let subst_univs = Vars.subst_instance_constr (Univ.UContext.instance univ_ctx) in - let env = Environ.push_context univ_ctx env in - if global then - Global.push_context false univ_ctx; - let arity = arity_of_ind_body ind_body in - let arity_ctx = [CRD.LocalAssum (Name.Anonymous, arity)] in - let ctors_typ = Array.map (recompose_prod_assum arity_ctx) ind_body.mind_user_lc in - env, univs, subst_univs arity, Array.map_to_list subst_univs ctors_typ - -let declare_inductive typename consnames template univs nparam arity constypes = - let open Entries in - let params, arity = Term.decompose_prod_n_assum nparam arity in - let constypes = List.map (Term.decompose_prod_n_assum (nparam + 1)) constypes in - let ind_entry = - { mind_entry_typename = typename; - mind_entry_arity = arity; - mind_entry_template = template; - mind_entry_consnames = consnames; - mind_entry_lc = List.map snd constypes } - in - let mind_entry = - { mind_entry_record = None; - mind_entry_finite = Declarations.Finite; - mind_entry_params = List.map make_ind_local_entry params; - mind_entry_inds = [ind_entry]; - mind_entry_universes = univs; - mind_entry_private = None } - in - let ((_, ker_name), _) = Declare.declare_mind mind_entry in - let mind = MutInd.make1 ker_name in - let ind = (mind, 0) in - Indschemes.declare_default_schemes mind; - ind - -(* --- Names --- *) - -(* Convert an external reference into a qualid *) -let qualid_of_reference = - Libnames.qualid_of_reference %> CAst.with_val identity - -(* Convert a term into a global reference with universes (or raise Not_found) *) -let pglobal_of_constr term = - match Constr.kind term with - | Const (const, univs) -> ConstRef const, univs - | Ind (ind, univs) -> IndRef ind, univs - | Construct (cons, univs) -> ConstructRef cons, univs - | Var id -> VarRef id, Univ.Instance.empty - | _ -> raise Not_found - -(* Convert a global reference with universes into a term *) -let constr_of_pglobal (glob, univs) = - match glob with - | ConstRef const -> mkConstU (const, univs) - | IndRef ind -> mkIndU (ind, univs) - | ConstructRef cons -> mkConstructU (cons, univs) - | VarRef id -> mkVar id - -type global_substitution = global_reference Globmap.t - -(* Substitute global references throughout a term *) -let subst_globals subst term = - let rec aux term = - try - pglobal_of_constr term |> - map_puniverses (flip Globmap.find subst) |> - constr_of_pglobal - with Not_found -> - Constr.map aux term - in - aux term - -(* --- Modules --- *) - -(* - * Pull any functor parameters off the module signature, returning the list of - * functor parameters and the list of module elements (i.e., fields). - *) -let decompose_module_signature mod_sign = - let rec aux mod_arity mod_sign = - match mod_sign with - | MoreFunctor (mod_name, mod_type, mod_sign) -> - aux ((mod_name, mod_type) :: mod_arity) mod_sign - | NoFunctor mod_fields -> - mod_arity, mod_fields - in - aux [] mod_sign - -(* - * Define an interactive (i.e., elementwise) module structure, with the - * functional argument called to populate the module elements. - * - * The optional argument specifies functor parameters. - *) -let declare_module_structure ?(params=[]) ident declare_elements = - let mod_sign = Vernacexpr.Check [] in - let mod_path = - Declaremods.start_module Modintern.interp_module_ast None ident params mod_sign - in - Dumpglob.dump_moddef mod_path "mod"; - declare_elements (); - let mod_path = Declaremods.end_module () in - Dumpglob.dump_modref mod_path "mod"; - Flags.if_verbose Feedback.msg_info - Pp.(str "\nModule " ++ Id.print ident ++ str " is defined"); - mod_path - -(* Type-sensitive transformation of terms *) -type constr_transformer = env -> evar_map ref -> constr -> constr - -(* - * Declare a new constant under the given name with the transformed term and - * type from the given constant. - * - * NOTE: Global side effects. - *) -let transform_constant ident tr_constr const_body = - let env = - match const_body.const_universes with - | Monomorphic_const univs -> - Global.env () |> Environ.push_context_set univs - | Polymorphic_const univs -> - CErrors.user_err ~hdr:"transform_constant" - Pp.(str "Universe polymorphism is not supported") - in - let term = force_constant_body const_body in - let evm = ref (Evd.from_env env) in - let term' = tr_constr env evm term in - let type' = tr_constr env evm const_body.const_type in - define_term ~typ:type' ident !evm term' true |> Globnames.destConstRef - -(* - * Declare a new inductive family under the given name with the transformed type - * arity and constructor types from the given inductive definition. Names for - * the constructors remain the same. - * - * NOTE: Global side effects. - *) -let transform_inductive ident tr_constr ((mind_body, ind_body) as ind_specif) = - (* TODO: Can we re-use this for ornamental lifting of inductive families? *) - let env = Global.env () in - let env, univs, arity, cons_types = - open_inductive ~global:true env ind_specif - in - let evm = ref (Evd.from_env env) in - let arity' = tr_constr env evm arity in - let cons_types' = List.map (tr_constr env evm) cons_types in - declare_inductive - ident (Array.to_list ind_body.mind_consnames) - (is_ind_body_template ind_body) univs - mind_body.mind_nparams arity' cons_types' - -(* - * Declare a new module structure under the given name with the compositionally - * transformed (i.e., forward-substituted) components from the given module - * structure. Names for the components remain the same. - * - * The optional initialization function is called immediately after the module - * structure begins, and its returned subsitution is applied to all other module - * elements. - * - * NOTE: Does not support functors or nested modules. - * NOTE: Global side effects. - *) -let transform_module_structure ?(init=const Globmap.empty) ident tr_constr mod_body = - let mod_path = mod_body.mod_mp in - let mod_arity, mod_elems = decompose_module_signature mod_body.mod_type in - assert (List.is_empty mod_arity); (* Functors are not yet supported *) - let transform_module_element subst (label, body) = - let ident = Label.to_id label in - let tr_constr env evm = subst_globals subst %> tr_constr env evm in - match body with - | SFBconst const_body -> - let const = Constant.make2 mod_path label in - if Globmap.mem (ConstRef const) subst then - subst (* Do not transform schematic definitions. *) - else - let const' = transform_constant ident tr_constr const_body in - Globmap.add (ConstRef const) (ConstRef const') subst - | SFBmind mind_body -> - check_inductive_supported mind_body; - let ind = (MutInd.make2 mod_path label, 0) in - let ind_body = mind_body.mind_packets.(0) in - let ind' = transform_inductive ident tr_constr (mind_body, ind_body) in - let ncons = Array.length ind_body.mind_consnames in - let list_cons ind = List.init ncons (fun i -> ConstructRef (ind, i + 1)) in - let sorts = ind_body.mind_kelim in - let list_elim ind = List.map (Indrec.lookup_eliminator ind) sorts in - Globmap.add (IndRef ind) (IndRef ind') subst |> - List.fold_right2 Globmap.add (list_cons ind) (list_cons ind') |> - List.fold_right2 Globmap.add (list_elim ind) (list_elim ind') - | SFBmodule mod_body -> - Feedback.msg_warning - Pp.(str "Skipping nested module structure " ++ Label.print label); - subst - | SFBmodtype sig_body -> - Feedback.msg_warning - Pp.(str "Skipping nested module signature " ++ Label.print label); - subst - in - declare_module_structure - ident - (fun () -> - ignore (List.fold_left transform_module_element (init ()) mod_elems)) diff --git a/plugin/src/library/coq/coqterms.mli b/plugin/src/library/coq/coqterms.mli deleted file mode 100644 index ab344d8..0000000 --- a/plugin/src/library/coq/coqterms.mli +++ /dev/null @@ -1,338 +0,0 @@ -(* - * Coq term and environment management - *) - -open Context -open Environ -open Constr -open Evd -open Constrexpr -open Names -open Declarations -open Globnames -open Decl_kinds - -module Globmap = Globnames.Refmap -module Globset = Globnames.Refset - -module CRD = Context.Rel.Declaration - -(* --- Auxiliary types --- *) - -type closure = env * (types list) - -(* --- Constants --- *) - -val eq_ind_r : types -val eq_ind : types -val eq_rec_r : types -val eq_rec : types -val eq_sym : types - -(* --- Questions about constants --- *) - -(* - * Determine if a term applies an identity term - * For efficiency, don't consider convertible terms - *) -val applies_identity : types -> bool - -(* - * Check if a term is a rewrite via eq_ind or eq_ind_r - * For efficiency, don't consider convertible terms - *) -val is_rewrite : types -> bool - -(* --- Convenient applications of constants --- *) - -(* - * Get the Coq identity function instantiated at a given type - *) -val identity_term : env -> types -> types - -(* --- Representations --- *) - -(* - * Intern a term (for now, ignore the resulting evar_map) - *) -val intern : env -> evar_map -> constr_expr -> types - -(* - * Extern a term - *) -val extern : env -> evar_map -> types -> constr_expr - -(* - * Define a new Coq term - * Refresh universes if the bool is true, otherwise don't - * (Refreshing universes is REALLY costly) - *) -val define_term : ?typ:types -> Id.t -> evar_map -> types -> bool -> global_reference - -(* --- Constructing terms --- *) - -(* - * Switch between products and lambdas, without changing anything else - *) -val prod_to_lambda : types -> types -val lambda_to_prod : types -> types - -(* --- Inductive types and their eliminators --- *) - -(* - * Fail if the inductive type is mutually inductive or coinductive - *) -val check_inductive_supported : mutual_inductive_body -> unit - -(* - * Get the number of constructors for an inductive type - *) -val num_constrs : mutual_inductive_body -> int - -(* - * Get an inductive type from an eliminator, if possible - *) -val inductive_of_elim : env -> pconstant -> mutual_inductive option - -(* --- Environments --- *) - -(* Look up all indexes from a list in an environment *) -val lookup_rels : int list -> env -> Rel.Declaration.t list - -(* Return a list of all indexes in an environment, starting with 1 *) -val all_rel_indexes : env -> int list - -(* Return a list of all bindings in an environment, starting with the closest *) -val lookup_all_rels : env -> Rel.Declaration.t list - -(* - * Push to an environment - *) -val push_local : (name * types) -> env -> env -val push_let_in : (name * types * types) -> env -> env - -(* Is the rel declaration a local assumption? *) -val is_rel_assum : ('constr, 'types) Rel.Declaration.pt -> bool - -(* Is the rel declaration a local definition? *) -val is_rel_defin : ('constr, 'types) Rel.Declaration.pt -> bool - -(* - * Construct a rel declaration - *) -val rel_assum : Name.t * 'types -> ('constr, 'types) Rel.Declaration.pt -val rel_defin : Name.t * 'constr * 'types -> ('constr, 'types) Rel.Declaration.pt - -(* - * Project a component of a rel declaration - *) -val rel_name : ('constr, 'types) Rel.Declaration.pt -> Name.t -val rel_value : ('constr, 'types) Rel.Declaration.pt -> 'constr option -val rel_type : ('constr, 'types) Rel.Declaration.pt -> 'types - -(* - * Map over a rel context with environment kept in synch - *) -val map_rel_context : env -> (env -> Rel.Declaration.t -> 'a) -> Rel.t -> 'a list - -(* - * Bind all local declarations in the relative context onto the body term as - * products, substituting away (i.e., zeta-reducing) any local definitions. - *) -val smash_prod_assum : Rel.t -> types -> types - -(* - * Bind all local declarations in the relative context onto the body term as - * lambdas, substituting away (i.e., zeta-reducing) any local definitions. - *) -val smash_lam_assum : Rel.t -> constr -> constr - -(* - * Decompose the first n product bindings, zeta-reducing let bindings to reveal - * further product bindings when necessary. - *) -val decompose_prod_n_zeta : int -> types -> Rel.t * types - -(* - * Decompose the first n lambda bindings, zeta-reducing let bindings to reveal - * further lambda bindings when necessary. - *) -val decompose_lam_n_zeta : int -> constr -> Rel.t * constr - -(* - * Lookup from an environment - *) -val lookup_pop : int -> env -> (env * CRD.t list) -val lookup_definition : env -> types -> types -val unwrap_definition : env -> types -> types - -(* - * Get bindings to push to an environment - *) -val bindings_for_inductive : - env -> mutual_inductive_body -> one_inductive_body array -> CRD.t list -val bindings_for_fix : name array -> types array -> CRD.t list - -(* - * Reconstruct local bindings around a term - *) -val recompose_prod_assum : Rel.t -> types -> types -val recompose_lam_assum : Rel.t -> types -> types - -(* --- Basic questions about terms --- *) - -(* Is the first term equal to a "head" (application prefix) of the second? - * The notion of term equality is syntactic, by default modulo alpha, casts, - * application grouping, and universes. The result of this function is an - * informative boolean: an optional array, with None meaning false and Some - * meaning true and giving the trailing arguments. - * - * This function is similar to is_or_applies, except for term equality and the - * informative boolean result. - *) -val eq_constr_head : ?eq_constr:(constr -> constr -> bool) -> constr -> constr -> constr array option - -(* --- Convertibility, reduction, and types --- *) - -(* - * Type-checking - * - * Current implementation may cause universe leaks, which will just cause - * conservative failure of the plugin - *) -val infer_type : env -> evar_map -> types -> types - -(* Check whether a term has a given type *) -val has_type : env -> evar_map -> types -> types -> bool - -(* Safely infer the WHNF type of a term, updating the evar map. *) -val e_infer_type : env -> evar_map ref -> constr -> constr - -(* Safely infer the sort of a term, updating the evar map. *) -val e_infer_sort : env -> evar_map ref -> constr -> Sorts.family - -(* Safely instantiate a global reference, updating the evar map. *) -val e_new_global : evar_map ref -> global_reference -> constr - -(* Convertibility, ignoring universe inconsistency for now *) -val convertible : env -> evar_map -> types -> types -> bool - -(* - * Checks whether the conclusions of two dependent types are convertible, - * modulo the assumption that every argument we encounter is equal when - * the types of those arguments are convertible. Expect exactly the same - * number of arguments in the same order. - * - * For example, the following are true: - * concls_convertible empty Evd.empty (forall (a : nat), a) (forall (a : nat) b, a) - * concls_convertible empty Evd.empty (forall (a : nat), a) (forall (a : nat), a) - * concls_convertible empty Evd.empty (forall (a : nat), True) (forall (b : bin), True) - * - * The following are false: - * concls_convertible empty Evd.empty (forall a, True) False - * concls_convertible empty Evd.empty (forall a, True) True - * concls_convertible empty Evd.empty (forall (a : nat), a) (forall (a : bin), a) - * concls_convertible empty Evd.empty (forall a b, a) (forall a b, b) - * - * Assumes types are locally closed. - *) -val concls_convertible : env -> evar_map -> types -> types -> bool - -(* - * Reduction - *) -val reduce_term : env -> types -> types (* betaiotazeta *) -val delta : env -> types -> types (* delta *) -val reduce_nf : env -> types -> types (* nf_all *) -val reduce_type : env -> evar_map -> types -> types (* betaiotazeta on types *) -val chain_reduce : (* sequencing *) - (env -> types -> types) -> - (env -> types -> types) -> - env -> - types -> - types - -(* - * Apply a function on a type instead of on the term - *) -val on_type : (types -> 'a) -> env -> evar_map -> types -> 'a - -(* - * Checks whether the types of two terms are convertible - *) -val types_convertible : env -> evar_map -> types -> types -> bool - -(* --- Names --- *) - -(* Convert an external reference into a qualid *) -val qualid_of_reference : Libnames.reference -> Libnames.qualid - -(* Convert a term into a global reference with universes (or raise Not_found) *) -val pglobal_of_constr : constr -> global_reference Univ.puniverses - -(* Convert a global reference with universes into a term *) -val constr_of_pglobal : global_reference Univ.puniverses -> constr - -type global_substitution = global_reference Globmap.t - -(* Substitute global references throughout a term *) -val subst_globals : global_substitution -> constr -> constr - -(* --- Modules --- *) - -(* Type-sensitive transformation of terms *) -type constr_transformer = env -> evar_map ref -> constr -> constr - -(* - * Declare a new constant under the given name with the transformed term and - * type from the given constant. - * - * NOTE: Global side effects. - *) -val transform_constant : Id.t -> constr_transformer -> constant_body -> Constant.t - -(* - * Declare a new inductive family under the given name with the transformed type - * arity and constructor types from the given inductive definition. Names for - * the constructors remain the same. - * - * NOTE: Global side effects. - *) -val transform_inductive : Id.t -> constr_transformer -> Inductive.mind_specif -> inductive - -(* - * Declare a new module structure under the given name with the compositionally - * transformed (i.e., forward-substituted) components from the given module - * structure. Names for the components remain the same. - * - * The optional initialization function is called immediately after the module - * structure begins, and its returned subsitution is applied to all other module - * elements. - * - * NOTE: Does not support functors or nested modules. - * NOTE: Global side effects. - *) -val transform_module_structure : ?init:(unit -> global_substitution) -> Id.t -> constr_transformer -> module_body -> ModPath.t - -(* --- Application and arguments --- *) - -(* - * Get a list of all arguments of a type unfolded at the head - * Return empty if it's not an application - *) -val unfold_args : types -> types list - -(* - * Get the very last argument of an application - *) -val last_arg : types -> types - -(* - * Get the very first function of an application - *) -val first_fun : types -> types - -(* - * Fully unfold arguments, then get the argument at a given position - *) -val get_arg : int -> types -> types diff --git a/plugin/src/library/coq/debruijn.ml b/plugin/src/library/coq/debruijn.ml deleted file mode 100644 index b88f711..0000000 --- a/plugin/src/library/coq/debruijn.ml +++ /dev/null @@ -1,97 +0,0 @@ -(* --- DeBruijn management --- *) - -open Environ -open Constr -open Hofs -open Utilities -open Coqterms - -(* TODO move shiftability into a module/functor *) - -(* --- Indexes --- *) - -(* Unshift an index by n *) -let unshift_i_by (n : int) (i : int) : int = - i - n - -(* Shift an index by n *) -let shift_i_by (n : int) (i : int) : int = - unshift_i_by (- n) i - -(* Unshift an index *) -let unshift_i (i : int) : int = - unshift_i_by 1 i - -(* Shift an index *) -let shift_i (i : int) : int = - shift_i_by 1 i - -(* --- Terms --- *) - -(* - * Unshifts a term by n if it is greater than the maximum index - * max of a local binding - *) -let unshift_local (max : int) (n : int) (trm : types) : types = - map_term - (fun (m, adj) t -> - match kind t with - | Rel i -> - let i' = if i > m then unshift_i_by adj i else i in - mkRel i' - | _ -> - t) - (fun (m, adj) -> (shift_i m, adj)) - (max, n) - trm - -(* - * Shifts a term by n if it is greater than the maximum index - * max of a local binding - *) -let shift_local (max : int) (n : int) (trm : types) : types = - unshift_local max (- n) trm - -(* Decrement the relative indexes of a term t by n *) -let unshift_by (n : int) (trm : types) : types = - unshift_local 0 n trm - -(* Increment the relative indexes of a term t by n *) -let shift_by (n : int) (t : types) : types = - unshift_by (- n) t - -(* Increment the relative indexes of a term t by one *) -let shift (t : types) : types = - shift_by 1 t - -(* Decrement the relative indexes of a term t by one *) -let unshift (t : types) : types = - unshift_by 1 t - -(* Shift everything and pray; workaround for bug *) -let shift_by_unconditional (n : int) (trm : types) : types = - map_term - (fun _ t -> - match kind t with - | Rel i -> - let i' = shift_i_by n i in - mkRel i' - | _ -> - t) - (fun _ -> ()) - () - trm - -(* --- Environments --- *) - -(* Unshifts indexes for terms in env by n *) -let unshift_env_by (n : int) (env : env) : env = - let num_rels = nb_rel env in - let all_relis = List.rev (from_one_to num_rels) in - let all_rels = lookup_rels all_relis env in - List.fold_left - (fun env decl -> - push_rel decl env) - (pop_rel_context num_rels env) - all_rels - diff --git a/plugin/src/library/coq/debruijn.mli b/plugin/src/library/coq/debruijn.mli deleted file mode 100644 index 9b339d9..0000000 --- a/plugin/src/library/coq/debruijn.mli +++ /dev/null @@ -1,53 +0,0 @@ -(* DeBruijn management *) - -open Environ -open Constr - -(* --- Indexes --- *) - -(* Unshift an index by a given amount *) -val unshift_i_by : int -> int -> int - -(* Shift an index by a given amount *) -val shift_i_by : int -> int -> int - -(* Unshift an index *) -val unshift_i : int -> int - -(* Shift an index *) -val shift_i : int -> int - -(* --- Terms --- *) - -(* - * Unshifts a term by an amount if it is greater than the maximum index - * of a local binding - *) -val unshift_local : int -> int -> types -> types - -(* - * Shifts a term by an amount if it is greater than the maximum index - * of a local binding - *) -val shift_local : int -> int -> types -> types - -(* Decrement the relative indexes of a term by an amount *) -val unshift_by : int -> types -> types - -(* Increment the relative indexes of a term by an amount *) -val shift_by : int -> types -> types - -(* Increment the relative indexes of a term by one *) -val shift : types -> types - -(* Decrement the relative indexes of a term by one *) -val unshift : types -> types - -(* Shift everything and pray; workaround for bug *) -val shift_by_unconditional : int -> types -> types - -(* --- Environments --- *) - -(* Unshifts indexes for terms in an environment by an amount *) -val unshift_env_by : int -> env -> env - diff --git a/plugin/src/library/coq/filters.ml b/plugin/src/library/coq/filters.ml deleted file mode 100644 index f394918..0000000 --- a/plugin/src/library/coq/filters.ml +++ /dev/null @@ -1,51 +0,0 @@ -(* Filters *) - -open Constr -open Environ -open Coqterms -open Debruijn -open Evd - -type 'a filter_strategy = env -> evar_map -> 'a list -> 'a list - -(* Filter trms to those that have type typ in env *) -let filter_by_type typ (env : env) (evd : evar_map) (trms : types list) : types list = - try - List.filter (has_type env evd typ) trms - with - | _ -> [] - -(* Find the singleton list with the first term that has type typ *) -let find_by_type typ (env : env) (evd : evar_map) (trms : types list) : types list = - try - [List.find (has_type env evd typ) trms] - with - | _ -> [] - -(* Filter a list of terms to those not exactly the same as the supplied term *) -let filter_not_same trm (_ : env) (_ : evar_map) (trms : types list) : types list = - let same = equal trm in (* exact equality for constructors *) - List.filter (fun t -> not (same t)) trms - -(* - * Eliminate inductive hypotheses if possible. - * This takes in a list of reduced candidates and filters out - * the ones that still reference the IH. - * - * For now, only deals with candidates that refer explicitly to IH. - * The ones that do will not pass the filter, - * while the ones that don't will, and will then be type-checked. - * - * Sometimes this will not be possible, in which case we need a backup plan. - * This is not yet implemented. - *) -let filter_ihs (env : env) (evd : evar_map) (cs : types list) : types list = - let env_no_ih = pop_rel_context 1 env in - List.filter - (fun c -> - let c_no_ih = unshift c in - try - ignore (infer_type env_no_ih evd c_no_ih); - true - with _ -> false) - cs diff --git a/plugin/src/library/coq/filters.mli b/plugin/src/library/coq/filters.mli deleted file mode 100644 index 125883f..0000000 --- a/plugin/src/library/coq/filters.mli +++ /dev/null @@ -1,20 +0,0 @@ -(* Filters for terms and eterms *) - -open Constr -open Environ -open Evd - -type 'a filter_strategy = env -> evar_map -> 'a list -> 'a list - -(* Filter a list of terms to those that have the goal type *) -val filter_by_type : types -> types filter_strategy - -(* Find the singleton list with the first term that has the goal type *) -val find_by_type : types -> types filter_strategy - -(* Filter a list of terms to those not exactly the same as the supplied term *) -val filter_not_same : types -> types filter_strategy - -(* Filter a list of reduced candidates to those that do not reference the IH *) -val filter_ihs : types filter_strategy - diff --git a/plugin/src/library/coq/hofs.ml b/plugin/src/library/coq/hofs.ml deleted file mode 100644 index 1500d41..0000000 --- a/plugin/src/library/coq/hofs.ml +++ /dev/null @@ -1,495 +0,0 @@ -(* Higher-order functions on terms *) - -(* TODO maps should handle other types, right now don't yet *) -(* TODO can still generalize these to make them easier to extend further *) - -open Environ -open Constr -open Coqterms -open Utilities -open Names - -module CRD = Context.Rel.Declaration - -(* Predicates to determine whether to apply a mapped function *) -type ('a, 'b) pred = 'a -> 'b -> bool -type ('a, 'b) pred_with_env = env -> ('a, 'b) pred - -(* Functions to use in maps *) -type ('a, 'b) transformer = 'a -> 'b -> 'b -type ('a, 'b) cartesian_transformer = 'a -> 'b -> 'b list -type ('a, 'b) transformer_with_env = env -> 'a -> 'b -> 'b -type ('a, 'b) cartesian_transformer_with_env = env -> 'a -> 'b -> 'b list - -(* Updating arguments *) -type 'a updater = 'a -> 'a - -(* Mapper functions *) -type ('a, 'b) mapper_with_env = - ('a, 'b) transformer_with_env -> - 'a updater -> - ('a, 'b) transformer_with_env - -type ('a, 'b) mapper = - ('a, 'b) transformer -> - 'a updater -> - ('a, 'b) transformer - -type ('a, 'b) cartesian_mapper_with_env = - ('a, 'b) cartesian_transformer_with_env -> - 'a updater -> - ('a, 'b) cartesian_transformer_with_env - -type ('a, 'b) cartesian_mapper = - ('a, 'b) cartesian_transformer -> - 'a updater -> - ('a, 'b) cartesian_transformer - -type ('a, 'b) conditional_mapper_with_env = - ('a, 'b) pred_with_env -> - ('a, 'b) transformer_with_env -> - 'a updater -> - ('a, 'b) transformer_with_env - -type ('a, 'b) conditional_mapper = - ('a, 'b) pred -> - ('a, 'b) transformer -> - 'a updater -> - ('a, 'b) transformer - -type ('a, 'b) conditional_cartesian_mapper_with_env = - ('a, 'b) pred_with_env -> - ('a, 'b) cartesian_transformer_with_env -> - 'a updater -> - ('a, 'b) cartesian_transformer_with_env - -(* Specific predicates and functions for implementation *) -type 'a p_no_env = ('a, types) pred -type 'a p_with_env = ('a, types) pred_with_env -type 'a f_no_env = ('a, types) transformer -type 'a f_with_env = ('a, types) transformer_with_env -type 'a f_cart_with_env = ('a, types) cartesian_transformer_with_env -type 'a f_cart_no_env = ('a, types) cartesian_transformer - -(* --- Terms --- *) - -(* - * Recurse on a mapping function with an environment for a fixpoint - *) -let map_rec_env_fix (map_rec : ('a, 'b) transformer_with_env) (d : 'a updater) (env : env) (a : 'a) (ns : Name.t array) (ts : types array) = - let fix_bindings = bindings_for_fix ns ts in - let env_fix = push_rel_context fix_bindings env in - let n = List.length fix_bindings in - let d_n = List.fold_left (fun a' _ -> d a') a (range 0 n) in - map_rec env_fix d_n - -(* - * Recurse on a mapping function with an environment for a fixpoint - *) -let map_rec_env_fix_cartesian (map_rec : ('a, 'b) cartesian_transformer_with_env) (d : 'a updater) (env : env) (a : 'a) (ns : Name.t array) (ts : types array) = - let fix_bindings = bindings_for_fix ns ts in - let env_fix = push_rel_context fix_bindings env in - let n = List.length fix_bindings in - let d_n = List.fold_left (fun a' _ -> d a') a (range 0 n) in - map_rec env_fix d_n - -(* - * Map a function over a term in an environment - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -let rec map_term_env (f : 'a f_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types = - let map_rec = map_term_env f d in - match kind trm with - | Cast (c, k, t) -> - let c' = map_rec env a c in - let t' = map_rec env a t in - mkCast (c', k, t') - | Prod (n, t, b) -> - let t' = map_rec env a t in - let b' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - mkProd (n, t', b') - | Lambda (n, t, b) -> - let t' = map_rec env a t in - let b' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - mkLambda (n, t', b') - | LetIn (n, trm, typ, e) -> - let trm' = map_rec env a trm in - let typ' = map_rec env a typ in - let e' = map_rec (push_rel CRD.(LocalDef(n, e, typ)) env) (d a) e in - mkLetIn (n, trm', typ', e') - | App (fu, args) -> - let fu' = map_rec env a fu in - let args' = Array.map (map_rec env a) args in - mkApp (fu', args') - | Case (ci, ct, m, bs) -> - let ct' = map_rec env a ct in - let m' = map_rec env a m in - let bs' = Array.map (map_rec env a) bs in - mkCase (ci, ct', m', bs') - | Fix ((is, i), (ns, ts, ds)) -> - let ts' = Array.map (map_rec env a) ts in - let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in - mkFix ((is, i), (ns, ts', ds')) - | CoFix (i, (ns, ts, ds)) -> - let ts' = Array.map (map_rec env a) ts in - let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in - mkCoFix (i, (ns, ts', ds')) - | Proj (p, c) -> - let c' = map_rec env a c in - mkProj (p, c') - | _ -> - f env a trm - -(* - * Map a function over a term, when the environment doesn't matter - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -let map_term (f : 'a f_no_env) (d : 'a updater) (a : 'a) (trm : types) : types = - map_term_env (fun _ a t -> f a t) d empty_env a trm - -(* - * Map a function over subterms of a term in an environment - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -let rec map_subterms_env (f : 'a f_cart_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types list = - let map_rec = map_subterms_env f d in - match kind trm with - | Cast (c, k, t) -> - let cs' = map_rec env a c in - let ts' = map_rec env a t in - combine_cartesian (fun c' t' -> mkCast (c', k, t')) cs' ts' - | Prod (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkProd (n, t', b')) ts' bs' - | Lambda (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkLambda (n, t', b')) ts' bs' - | LetIn (n, trm, typ, e) -> - let trms' = map_rec env a trm in - let typs' = map_rec env a typ in - let es' = map_rec (push_rel CRD.(LocalDef(n, e, typ)) env) (d a) e in - combine_cartesian (fun trm' (typ', e') -> mkLetIn (n, trm', typ', e')) trms' (cartesian typs' es') - | App (fu, args) -> - let fus' = map_rec env a fu in - let argss' = combine_cartesian_append (Array.map (map_rec env a) args) in - combine_cartesian (fun fu' args' -> mkApp (fu', args')) fus' argss' - | Case (ci, ct, m, bs) -> - let cts' = map_rec env a ct in - let ms' = map_rec env a m in - let bss' = combine_cartesian_append (Array.map (map_rec env a) bs) in - combine_cartesian (fun ct' (m', bs') -> mkCase (ci, ct', m', bs')) cts' (cartesian ms' bss') - | Fix ((is, i), (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkFix ((is, i), (ns, ts', ds'))) tss' dss' - | CoFix (i, (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkCoFix (i, (ns, ts', ds'))) tss' dss' - | Proj (p, c) -> - let cs' = map_rec env a c in - List.map (fun c' -> mkProj (p, c')) cs' - | _ -> - f env a trm - -(* - * Map a function over subterms of a term, when the environment doesn't matter - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -let map_subterms (f : 'a f_cart_no_env) (d : 'a updater) (a : 'a) (trm : types) : types list = - map_subterms_env (fun _ a t -> f a t) d empty_env a trm - -(* - * Map a function over a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -let rec map_term_env_if (p : 'a p_with_env) (f : 'a f_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types = - let map_rec = map_term_env_if p f d in - if p env a trm then - f env a trm - else - match kind trm with - | Cast (c, k, t) -> - let c' = map_rec env a c in - let t' = map_rec env a t in - mkCast (c', k, t') - | Prod (n, t, b) -> - let t' = map_rec env a t in - let b' = map_rec (push_rel CRD.(LocalAssum(n, t')) env) (d a) b in - mkProd (n, t', b') - | Lambda (n, t, b) -> - let t' = map_rec env a t in - let b' = map_rec (push_rel CRD.(LocalAssum(n, t')) env) (d a) b in - mkLambda (n, t', b') - | LetIn (n, trm, typ, e) -> - let trm' = map_rec env a trm in - let typ' = map_rec env a typ in - let e' = map_rec (push_rel CRD.(LocalDef(n, e, typ')) env) (d a) e in - mkLetIn (n, trm', typ', e') - | App (fu, args) -> - let fu' = map_rec env a fu in - let args' = Array.map (map_rec env a) args in - mkApp (fu', args') - | Case (ci, ct, m, bs) -> - let ct' = map_rec env a ct in - let m' = map_rec env a m in - let bs' = Array.map (map_rec env a) bs in - mkCase (ci, ct', m', bs') - | Fix ((is, i), (ns, ts, ds)) -> - let ts' = Array.map (map_rec env a) ts in - let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in - mkFix ((is, i), (ns, ts', ds')) - | CoFix (i, (ns, ts, ds)) -> - let ts' = Array.map (map_rec env a) ts in - let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in - mkCoFix (i, (ns, ts', ds')) - | Proj (pr, c) -> - let c' = map_rec env a c in - mkProj (pr, c') - | _ -> - trm - -(* - * Map a function over a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Don't recurse into lambda arguments - * Return a new term - *) -let rec map_term_env_if_shallow (p : 'a p_with_env) (f : 'a f_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types = - let map_rec = map_term_env_if_shallow p f d in - if p env a trm then - f env a trm - else - match kind trm with - | Cast (c, k, t) -> - let c' = map_rec env a c in - let t' = map_rec env a t in - mkCast (c', k, t') - | Prod (n, t, b) -> - let t' = map_rec env a t in - let b' = map_rec (push_rel CRD.(LocalAssum(n, t')) env) (d a) b in - mkProd (n, t', b') - | Lambda (n, t, b) -> - let t' = map_rec env a t in - let b' = map_rec (push_rel CRD.(LocalAssum(n, t')) env) (d a) b in - mkLambda (n, t', b') - | LetIn (n, trm, typ, e) -> - let trm' = map_rec env a trm in - let typ' = map_rec env a typ in - let e' = map_rec (push_rel CRD.(LocalDef(n, e, typ')) env) (d a) e in - mkLetIn (n, trm', typ', e') - | App (fu, args) -> - let fu' = map_rec env a fu in - let args' = - Array.map - (fun t -> if isLambda t then t else map_rec env a t) - args - in mkApp (fu', args') - | Case (ci, ct, m, bs) -> - let ct' = map_rec env a ct in - let m' = map_rec env a m in - let bs' = Array.map (map_rec env a) bs in - mkCase (ci, ct', m', bs') - | Fix ((is, i), (ns, ts, ds)) -> - let ts' = Array.map (map_rec env a) ts in - let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in - mkFix ((is, i), (ns, ts', ds')) - | CoFix (i, (ns, ts, ds)) -> - let ts' = Array.map (map_rec env a) ts in - let ds' = Array.map (map_rec_env_fix map_rec d env a ns ts) ds in - mkCoFix (i, (ns, ts', ds')) - | Proj (pr, c) -> - let c' = map_rec env a c in - mkProj (pr, c') - | _ -> - trm - - -(* - * Map a function over a term where the environment doesn't matter - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -let map_term_if (p : 'a p_no_env) (f : 'a f_no_env) (d : 'a updater) (a : 'a) (trm : types) : types = - map_term_env_if (fun _ a t -> p a t) (fun _ a t -> f a t) d empty_env a trm - -(* - * Map a function over subterms of a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -let rec map_subterms_env_if (p : 'a p_with_env) (f : 'a f_cart_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types list = - let map_rec = map_subterms_env_if p f d in - if p env a trm then - f env a trm - else - match kind trm with - | Cast (c, k, t) -> - let cs' = map_rec env a c in - let ts' = map_rec env a t in - combine_cartesian (fun c' t' -> mkCast (c', k, t')) cs' ts' - | Prod (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkProd (n, t', b')) ts' bs' - | Lambda (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkLambda (n, t', b')) ts' bs' - | LetIn (n, trm, typ, e) -> - let trms' = map_rec env a trm in - let typs' = map_rec env a typ in - let es' = map_rec (push_rel CRD.(LocalDef(n, e, typ)) env) (d a) e in - combine_cartesian (fun trm' (typ', e') -> mkLetIn (n, trm', typ', e')) trms' (cartesian typs' es') - | App (fu, args) -> - let fus' = map_rec env a fu in - let argss' = combine_cartesian_append (Array.map (map_rec env a) args) in - combine_cartesian (fun fu' args' -> mkApp (fu', args')) fus' argss' - | Case (ci, ct, m, bs) -> - let cts' = map_rec env a ct in - let ms' = map_rec env a m in - let bss' = combine_cartesian_append (Array.map (map_rec env a) bs) in - combine_cartesian (fun ct' (m', bs') -> mkCase (ci, ct', m', bs')) cts' (cartesian ms' bss') - | Fix ((is, i), (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkFix ((is, i), (ns, ts', ds'))) tss' dss' - | CoFix (i, (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkCoFix (i, (ns, ts', ds'))) tss' dss' - | Proj (p, c) -> - let cs' = map_rec env a c in - List.map (fun c' -> mkProj (p, c')) cs' - | _ -> - [trm] - -(* - * Map a function over subterms of a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly, but always recurse - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -let rec map_subterms_env_if_combs (p : 'a p_with_env) (f : 'a f_cart_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types list = - let map_rec = map_subterms_env_if_combs p f d in - let trms = if p env a trm then f env a trm else [trm] in - flat_map - (fun trm' -> - match kind trm' with - | Cast (c, k, t) -> - let cs' = map_rec env a c in - let ts' = map_rec env a t in - combine_cartesian (fun c' t' -> mkCast (c', k, t')) cs' ts' - | Prod (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkProd (n, t', b')) ts' bs' - | Lambda (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkLambda (n, t', b')) ts' bs' - | LetIn (n, trm, typ, e) -> - let trms' = map_rec env a trm in - let typs' = map_rec env a typ in - let es' = map_rec (push_rel CRD.(LocalDef(n, e, typ)) env) (d a) e in - combine_cartesian (fun trm' (typ', e') -> mkLetIn (n, trm', typ', e')) trms' (cartesian typs' es') - | App (fu, args) -> - let fus' = map_rec env a fu in - let argss' = combine_cartesian_append (Array.map (map_rec env a) args) in - combine_cartesian (fun fu' args' -> mkApp (fu', args')) fus' argss' - | Case (ci, ct, m, bs) -> - let cts' = map_rec env a ct in - let ms' = map_rec env a m in - let bss' = combine_cartesian_append (Array.map (map_rec env a) bs) in - combine_cartesian (fun ct' (m', bs') -> mkCase (ci, ct', m', bs')) cts' (cartesian ms' bss') - | Fix ((is, i), (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkFix ((is, i), (ns, ts', ds'))) tss' dss' - | CoFix (i, (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkCoFix (i, (ns, ts', ds'))) tss' dss' - | Proj (p, c) -> - let cs' = map_rec env a c in - List.map (fun c' -> mkProj (p, c')) cs' - | _ -> - [trm']) - trms - -(* - * Map a function over subterms of a term in an environment - * Only apply the function when a proposition is true - * Apply the function after recursing - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - * - * TODO redundant calls right now - *) -let rec map_subterms_env_if_lazy (p : 'a p_with_env) (f : 'a f_cart_with_env) (d : 'a updater) (env : env) (a : 'a) (trm : types) : types list = - let map_rec = map_subterms_env_if_lazy p f d in - let trms' = - match kind trm with - | Cast (c, k, t) -> - let cs' = map_rec env a c in - let ts' = map_rec env a t in - combine_cartesian (fun c' t' -> mkCast (c', k, t')) cs' ts' - | Prod (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkProd (n, t', b')) ts' bs' - | Lambda (n, t, b) -> - let ts' = map_rec env a t in - let bs' = map_rec (push_rel CRD.(LocalAssum(n, t)) env) (d a) b in - combine_cartesian (fun t' b' -> mkLambda (n, t', b')) ts' bs' - | LetIn (n, trm, typ, e) -> - let trms' = map_rec env a trm in - let typs' = map_rec env a typ in - let es' = map_rec (push_rel CRD.(LocalDef(n, e, typ)) env) (d a) e in - combine_cartesian (fun trm' (typ', e') -> mkLetIn (n, trm', typ', e')) trms' (cartesian typs' es') - | App (fu, args) -> - let fus' = map_rec env a fu in - let argss' = combine_cartesian_append (Array.map (map_rec env a) args) in - combine_cartesian (fun fu' args' -> mkApp (fu', args')) fus' argss' - | Case (ci, ct, m, bs) -> - let cts' = map_rec env a ct in - let ms' = map_rec env a m in - let bss' = combine_cartesian_append (Array.map (map_rec env a) bs) in - combine_cartesian (fun ct' (m', bs') -> mkCase (ci, ct', m', bs')) cts' (cartesian ms' bss') - | Fix ((is, i), (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkFix ((is, i), (ns, ts', ds'))) tss' dss' - | CoFix (i, (ns, ts, ds)) -> - let tss' = combine_cartesian_append (Array.map (map_rec env a) ts) in - let dss' = combine_cartesian_append (Array.map (map_rec_env_fix_cartesian map_rec d env a ns ts) ds) in - combine_cartesian (fun ts' ds' -> mkCoFix (i, (ns, ts', ds'))) tss' dss' - | Proj (p, c) -> - let cs' = map_rec env a c in - List.map (fun c' -> mkProj (p, c')) cs' - | _ -> - [trm] - in flat_map (fun trm' -> if p env a trm' then f env a trm' else [trm']) trms' diff --git a/plugin/src/library/coq/hofs.mli b/plugin/src/library/coq/hofs.mli deleted file mode 100644 index f4012ce..0000000 --- a/plugin/src/library/coq/hofs.mli +++ /dev/null @@ -1,149 +0,0 @@ -(* Higher-order functions on terms *) - -open Environ -open Constr -open Coqterms - -(* Predicates to determine whether to apply a mapped function *) -type ('a, 'b) pred = 'a -> 'b -> bool -type ('a, 'b) pred_with_env = env -> ('a, 'b) pred - -(* Functions to use in maps *) -type ('a, 'b) transformer = 'a -> 'b -> 'b -type ('a, 'b) cartesian_transformer = 'a -> 'b -> 'b list -type ('a, 'b) transformer_with_env = env -> 'a -> 'b -> 'b -type ('a, 'b) cartesian_transformer_with_env = env -> 'a -> 'b -> 'b list - -(* Updating arguments *) -type 'a updater = 'a -> 'a - -(* Mapper functions *) -type ('a, 'b) mapper_with_env = - ('a, 'b) transformer_with_env -> - 'a updater -> - ('a, 'b) transformer_with_env - -type ('a, 'b) mapper = - ('a, 'b) transformer -> - 'a updater -> - ('a, 'b) transformer - -type ('a, 'b) cartesian_mapper_with_env = - ('a, 'b) cartesian_transformer_with_env -> - 'a updater -> - ('a, 'b) cartesian_transformer_with_env - -type ('a, 'b) cartesian_mapper = - ('a, 'b) cartesian_transformer -> - 'a updater -> - ('a, 'b) cartesian_transformer - -type ('a, 'b) conditional_mapper_with_env = - ('a, 'b) pred_with_env -> - ('a, 'b) transformer_with_env -> - 'a updater -> - ('a, 'b) transformer_with_env - -type ('a, 'b) conditional_mapper = - ('a, 'b) pred -> - ('a, 'b) transformer -> - 'a updater -> - ('a, 'b) transformer - -type ('a, 'b) conditional_cartesian_mapper_with_env = - ('a, 'b) pred_with_env -> - ('a, 'b) cartesian_transformer_with_env -> - 'a updater -> - ('a, 'b) cartesian_transformer_with_env - -(* --- Terms --- *) - -(* - * Map a function over a term in an environment - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -val map_term_env : ('a, types) mapper_with_env - -(* - * Map a function over a term, when the environment doesn't matter - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -val map_term : ('a, types) mapper - -(* - * Map a function over subterms of a term in an environment - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -val map_subterms_env : ('a, types) cartesian_mapper_with_env - -(* - * Map a function over subterms of a term, when the environment doesn't matter - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -val map_subterms : ('a, types) cartesian_mapper - -(* - * Map a function over a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -val map_term_env_if : ('a, types) conditional_mapper_with_env - -(* - * Map a function over a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Don't recurse into lambda arguments - * Return a new term - *) -val map_term_env_if_shallow : ('a, types) conditional_mapper_with_env - -(* - * Map a function over a term where the environment doesn't matter - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the argument of type 'a using the a supplied update function - * Return a new term - *) -val map_term_if : ('a, types) conditional_mapper - -(* - * Map a function over subterms of a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -val map_subterms_env_if : ('a, types) conditional_cartesian_mapper_with_env - -(* - * Map a function over subterms of a term in an environment - * Only apply the function when a proposition is true - * Apply the function eagerly, but always recurse - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -val map_subterms_env_if_combs : ('a, types) conditional_cartesian_mapper_with_env - -(* - * Map a function over subterms of a term in an environment - * Only apply the function when a proposition is true - * Apply the function after recursing - * Update the environment as you go - * Update the argument of type 'a using the a supplied update function - * Return all combinations of new terms - *) -val map_subterms_env_if_lazy : ('a, types) conditional_cartesian_mapper_with_env diff --git a/plugin/src/library/coq/printing.ml b/plugin/src/library/coq/printing.ml deleted file mode 100644 index 4bd655e..0000000 --- a/plugin/src/library/coq/printing.ml +++ /dev/null @@ -1,184 +0,0 @@ -(* - * Auxiliary functions for printing. - * - * Some of these implementations are incomplete right now. - * Those pieces will show the wrong environments, so indexes will - * appear to be incorrect. - *) - -open Format -open Names -open Univ -open Constr -open Environ -open Printer -open Utilities -open Goptions -open Declarations -open Coqterms - -module CRD = Context.Rel.Declaration - -(* --- Strings --- *) - -(* - * Using pp, prints directly to a string - * TODO use this in category for as_string, to avoid extraneous envs - *) -let print_to_string (pp : formatter -> 'a -> unit) (trm : 'a) : string = - Format.asprintf "%a" pp trm - -(* --- Coq terms --- *) - -(* Gets n as a string *) -let name_as_string (n : Name.t) : string = - match n with - | Name id -> Id.to_string id - | Anonymous -> "_" - -(* Pretty prints a universe level *) -let print_univ_level (fmt : formatter) (l : Level.t) = - Pp.pp_with fmt (Level.pr l) - -(* Prints a universe *) -let universe_as_string u = - match Universe.level u with - | Some l -> print_to_string print_univ_level l - | None -> Printf.sprintf "Max{%s}" (String.concat ", " (List.map (print_to_string print_univ_level) (LSet.elements (Universe.levels u)))) - -(* Gets a sort as a string *) -let sort_as_string s = - match s with - | Term.Prop _ -> if s = Sorts.prop then "Prop" else "Set" - | Term.Type u -> Printf.sprintf "Type %s" (universe_as_string u) - -(* Prints a term *) -let rec term_as_string (env : env) (trm : types) = - match kind trm with - | Rel i -> - (try - let (n, _, _) = CRD.to_tuple @@ lookup_rel i env in - Printf.sprintf "(%s [Rel %d])" (name_as_string n) i - with - Not_found -> Printf.sprintf "(Unbound_Rel %d)" i) - | Var v -> - Id.to_string v - | Meta mv -> - failwith "Metavariables are not yet supported" - | Evar (k, cs) -> - Printf.sprintf "??" - | Sort s -> - sort_as_string s - | Cast (c, k, t) -> - Printf.sprintf "(%s : %s)" (term_as_string env c) (term_as_string env t) - | Prod (n, t, b) -> - Printf.sprintf "(Π (%s : %s) . %s)" (name_as_string n) (term_as_string env t) (term_as_string (push_rel CRD.(LocalAssum(n, t)) env) b) - | Lambda (n, t, b) -> - Printf.sprintf "(λ (%s : %s) . %s)" (name_as_string n) (term_as_string env t) (term_as_string (push_rel CRD.(LocalAssum(n, t)) env) b) - | LetIn (n, trm, typ, e) -> - Printf.sprintf "(let (%s : %s) := %s in %s)" (name_as_string n) (term_as_string env typ) (term_as_string env typ) (term_as_string (push_rel CRD.(LocalDef(n, e, typ)) env) e) - | App (f, xs) -> - Printf.sprintf "(%s %s)" (term_as_string env f) (String.concat " " (List.map (term_as_string env) (Array.to_list xs))) - | Const (c, u) -> - let ker_name = Constant.canonical c in - KerName.to_string ker_name - | Construct (((i, i_index), c_index), u) -> - let mutind_body = lookup_mind i env in - let ind_body = mutind_body.mind_packets.(i_index) in - let constr_name_id = ind_body.mind_consnames.(c_index - 1) in - Id.to_string constr_name_id - | Ind ((i, i_index), u) -> - let mutind_body = lookup_mind i env in - let ind_bodies = mutind_body.mind_packets in - let name_id = (ind_bodies.(i_index)).mind_typename in - Id.to_string name_id - | Case (ci, ct, m, bs) -> - let (i, i_index) = ci.ci_ind in - let mutind_body = lookup_mind i env in - let ind_body = mutind_body.mind_packets.(i_index) in - Printf.sprintf - "(match %s : %s with %s)" - (term_as_string env m) - (term_as_string env ct) - (String.concat - " " - (Array.to_list - (Array.mapi - (fun c_i b -> - Printf.sprintf - "(case %s => %s)" - (Id.to_string (ind_body.mind_consnames.(c_i))) - (term_as_string env b)) - bs))) - | Fix ((is, i), (ns, ts, ds)) -> - let env_fix = push_rel_context (bindings_for_fix ns ds) env in - String.concat - " with " - (map3 - (fun n t d -> - Printf.sprintf - "(Fix %s : %s := %s)" - (name_as_string n) - (term_as_string env t) - (term_as_string env_fix d)) - (Array.to_list ns) - (Array.to_list ts) - (Array.to_list ds)) - | CoFix (i, (ns, ts, ds)) -> - Printf.sprintf "TODO" (* TODO *) - | Proj (p, c) -> - Printf.sprintf "TODO" (* TODO *) - -(* --- Coq environments --- *) - -(* Gets env as a string *) -let env_as_string (env : env) : string = - let all_relis = all_rel_indexes env in - String.concat - ",\n" - (List.map - (fun i -> - let (n, b, t) = CRD.to_tuple @@ lookup_rel i env in - Printf.sprintf "%s (Rel %d): %s" (name_as_string n) i (term_as_string (pop_rel_context i env) t)) - all_relis) - -(* --- Debugging --- *) - -(* Print a separator string *) -let print_separator unit : unit = - Printf.printf "%s\n\n" "-----------------" - -(* Debug a term *) -let debug_term (env : env) (trm : types) (descriptor : string) : unit = - Printf.printf "%s: %s\n\n" descriptor (term_as_string env trm) - -(* Debug a list of terms *) -let debug_terms (env : env) (trms : types list) (descriptor : string) : unit = - List.iter (fun t -> debug_term env t descriptor) trms - -(* Debug an environment *) -let debug_env (env : env) (descriptor : string) : unit = - Printf.printf "%s: %s\n\n" descriptor (env_as_string env) - -(* Print a patch to stdout in the standard Coq format *) -let print_patch env evm patch_id patch : unit = - let opts = get_tables () in - let print_all = - match (OptionMap.find ["Printing"; "All"] opts).opt_value with - | BoolValue b -> b - | _ -> true - in - let _ = set_bool_option_value ["Printing"; "All"] true in - Pp.pp_with - Format.std_formatter - (Pp.pr_sequence - id - [(Pp.str "\nBEGIN PATCH"); - (Pp.str patch_id); - (Pp.str "\nDefinition"); - (Pp.str patch_id); - (Pp.str ":="); - (pr_lconstr_env env evm patch); - (Pp.str ".\nEND PATCH"); - (Pp.str "\n")]); - set_bool_option_value ["Printing"; "All"] print_all diff --git a/plugin/src/library/coq/printing.mli b/plugin/src/library/coq/printing.mli deleted file mode 100644 index c63e375..0000000 --- a/plugin/src/library/coq/printing.mli +++ /dev/null @@ -1,43 +0,0 @@ -(* Auxiliary functions for printing *) - -open Format -open Names -open Constr -open Environ -open Evd - -(* --- Strings --- *) - -(* Using a supplied pretty printing function, prints directly to a string *) -val print_to_string : (formatter -> 'a -> unit) -> 'a -> string - -(* --- Coq terms --- *) - -(* Gets a name as a string *) -val name_as_string : Name.t -> string - -(* Gets a term as a string in an environment *) -val term_as_string : env -> types -> string - -(* --- Coq environments --- *) - -(* Gets an environment as a string *) -val env_as_string : env -> string - -(* --- Debugging --- *) - -(* Print a separator string *) -val print_separator : unit -> unit - -(* Debug a term with a descriptor string *) -val debug_term : env -> types -> string -> unit - -(* Debug a list of terms with a descriptor string *) -val debug_terms : env -> types list -> string -> unit - -(* Debug an environment with a descriptor string *) -val debug_env : env -> string -> unit - -(* Print a patch to stdout in the standard Coq format *) -val print_patch : env -> evar_map -> string -> types -> unit - diff --git a/plugin/src/library/coq/reducers.ml b/plugin/src/library/coq/reducers.ml deleted file mode 100644 index 16b9f82..0000000 --- a/plugin/src/library/coq/reducers.ml +++ /dev/null @@ -1,117 +0,0 @@ -(* Strategies for reducing terms *) - -open Environ -open Evd -open Constr -open Hofs -open Coqterms -open Utilities -open Debruijn - -module CRD = Context.Rel.Declaration - -type reducer = env -> evar_map -> types -> types - -(* --- Top-level --- *) - -let reduce_all (r : reducer) env evd (trms : types list) : types list = - List.map (r env evd) trms - -(* --- Combinators and converters --- *) - -let chain_reduce (r1 : reducer) (r2 : reducer) env evd trm : types = - r2 env evd (r1 env evd trm) - -let try_reduce (r : reducer) (env : env) evd (trm : types) : types = - try r env evd trm with _ -> trm - -(* - * Reduce the body of a term using the supplied reducer if - * the predicate p is true on the body. If the term is a function, - * then this recurses into the body and checks the condition, and so on. - * It reduces as soon as the condition holds. - *) -let rec reduce_body_if p (r : reducer) env evd trm = - if p env trm then - r env evd trm - else - match kind trm with - | Lambda (n, t, b) -> - reduce_body_if p r (push_rel CRD.(LocalAssum(n, t)) env) evd b - | _ -> - failwith "Could not specialize" - -(* --- Defaults --- *) - -(* Default reducer *) -let reduce_term (env : env) (evd : evar_map) (trm : types) : types = - EConstr.to_constr - evd - (Reductionops.nf_betaiotazeta env evd (EConstr.of_constr trm)) - -(* --- Custom reducers --- *) - -(* Don't reduce *) -let do_not_reduce (env : env) (evd : evar_map) (trm : types) : types = - trm - -(* Remove all applications of the identity function *) -let remove_identities (env : env) (evd : evar_map) (trm : types) : types = - map_term_if - (fun _ t -> applies_identity t) - (fun _ t -> - match kind t with - | App (_, args) -> - Array.get args 1 - | _ -> - t) - id - () - trm - -(* Remove all applications of the identity function, then default reduce *) -let reduce_remove_identities : reducer = - chain_reduce remove_identities reduce_term - -(* Reduce and also unfold definitions *) -let reduce_unfold (env : env) (evd : evar_map) (trm : types) : types = - EConstr.to_constr - evd - (Reductionops.nf_all env evd (EConstr.of_constr trm)) - -(* Reduce and also unfold definitions, but weak head *) -let reduce_unfold_whd (env : env) (evd : evar_map) (trm : types) : types = - EConstr.to_constr - evd - (Reductionops.whd_all env evd (EConstr.of_constr trm)) - -(* Weak-head reduce a term if it is a let-in *) -let reduce_whd_if_let_in (env : env) (evd : evar_map) (trm : types) : types = - if isLetIn trm then - EConstr.to_constr - evd - (Reductionops.whd_betaiotazeta evd (EConstr.of_constr trm)) - else - trm - -(* - * This function removes any terms from the hypothesis of a lambda - * that are not referenced in the body, so that the term - * has only hypotheses that are referenced. - *) -let rec remove_unused_hypos (env : env) (evd : evar_map) (trm : types) : types = - match kind trm with - | Lambda (n, t, b) -> - let env_b = push_rel CRD.(LocalAssum(n, t)) env in - let b' = remove_unused_hypos env_b evd b in - (try - let num_rels = nb_rel env in - let env_ill = push_rel CRD.(LocalAssum (n, mkRel (num_rels + 1))) env in - let _ = infer_type env_ill evd b' in - remove_unused_hypos env evd (unshift b') - with _ -> - mkLambda (n, t, b')) - | _ -> - trm - - diff --git a/plugin/src/library/coq/reducers.mli b/plugin/src/library/coq/reducers.mli deleted file mode 100644 index 10d7841..0000000 --- a/plugin/src/library/coq/reducers.mli +++ /dev/null @@ -1,75 +0,0 @@ -(* Strategies for reducing terms *) - -open Environ -open Evd -open Constr - -type reducer = env -> evar_map -> types -> types - -(* --- Top-level --- *) - -val reduce_all : reducer -> env -> evar_map -> types list -> types list - -(* --- Defaults --- *) - -(* - * Default reducer - *) -val reduce_term : reducer - -(* --- Custom reducers --- *) - -(* - * Do not reduce - *) -val do_not_reduce : reducer - -(* - * Remove all applications of the identity function - *) -val remove_identities : reducer - -(* - * Remove unused hypotheses - *) -val remove_unused_hypos : reducer - -(* - * Remove all applications of the identity function, then default reduce - *) -val reduce_remove_identities : reducer - -(* - * Default reduce and also unfold definitions (delta-reduce, nf) - *) -val reduce_unfold : reducer - -(* - * Default reduce and also unfold definitions (delta-reduce, whd) - *) -val reduce_unfold_whd : reducer - -(* - * Weak-head reduce a term if it is a let-in (conditional betaiotazeta, whd) - *) -val reduce_whd_if_let_in : reducer - -(* --- Combinators and converters --- *) - -(* - * Reduce with the first reducer, then with the second reducer - *) -val chain_reduce : reducer -> reducer -> reducer - -(* - * Try to reduce, but let failure be OK - *) -val try_reduce : reducer -> reducer - -(* - * Reduce the body of a term using the supplied reducer if - * the predicate p is true on the body. If the term is a function, - * then this recurses into the body and checks the condition, and so on. - * It reduces as soon as the condition holds. - *) -val reduce_body_if : (env -> types -> bool) -> reducer -> reducer diff --git a/plugin/src/library/coq/substitution.ml b/plugin/src/library/coq/substitution.ml deleted file mode 100644 index fa252cb..0000000 --- a/plugin/src/library/coq/substitution.ml +++ /dev/null @@ -1,85 +0,0 @@ -(* Substitution auxiliary functions *) - -open Environ -open Evd -open Constr -open Coqterms -open Hofs -open Debruijn - -(* TODO clean up so retrieval is easier *) -type ('a, 'b) substitution = env -> evar_map -> 'a -> types -> 'b -type 'a comb_substitution = ('a, types list) substitution -type 'a type_substitution = ('a, types) substitution - -(* Map a substitution over a term *) -let all_substs p env evd (src, dst) trm : types = - map_term_env_if - (fun en (s, _) t -> p en evd s t) - (fun _ (_, d) _ -> d) - (fun (s, d) -> (shift s, shift d)) - env - (src, dst) - trm - -(* Map all combinations of a substitution over a term *) -let all_substs_combs p env evd (src, dst) trm : types list = - map_subterms_env_if - (fun en (s, _) t -> p en evd s t) - (fun _ (_, d) t -> [d; t]) - (fun (s, d) -> (shift s, shift d)) - env - (src, dst) - trm - -(* In env, substitute all subterms of trm that are convertible to src with dst *) -let all_conv_substs : (types * types) type_substitution = - all_substs convertible - -(* In env, substitute all subterms of trm that have a convertible type to the type of src with dst *) -let all_typ_substs : (types * types) type_substitution = - all_substs types_convertible - -(* - * Check if a subterm matches applies a constructor function pat to - * an argument with the type of itself - *) -let constructs_recursively env evd c trm : bool = - if isApp trm then - try - let (f, args) = destApp trm in - let conv = convertible env evd in - let types_conv = types_convertible env evd in - conv f c && List.exists (types_conv trm) (Array.to_list args) - with _ -> - false - else - false - -(* - * Map a constructor substitution over a term - * The constructor is a function c - * This finds the outermost applications of c to an argument - * with the type of the term itself, "undoing" the constructor - * It substitutes in the first argument with that type - * - * Can generalize this further - *) -let all_constr_substs env evd c trm : types = - map_term_env_if - (fun env -> constructs_recursively env evd) - (fun env _ t -> - let (_, args_t) = destApp t in - List.find (types_convertible env evd t) (Array.to_list args_t)) - shift - env - c - trm - -(* In env, return all substitutions of subterms of trm that are convertible to src with dst *) -let all_conv_substs_combs : (types * types) comb_substitution = - all_substs_combs convertible - -(* In env, return all substitutions of subterms of trm that have a convertible type to the type of src with dst *) -let all_typ_substs_combs : (types * types) comb_substitution = - all_substs_combs types_convertible diff --git a/plugin/src/library/coq/substitution.mli b/plugin/src/library/coq/substitution.mli deleted file mode 100644 index 96d96ff..0000000 --- a/plugin/src/library/coq/substitution.mli +++ /dev/null @@ -1,58 +0,0 @@ -(* Substitution auxiliary functions *) - -open Environ -open Constr -open Evd - -(* TODO clean up so retrieval is easier *) -type ('a, 'b) substitution = env -> evar_map -> 'a -> types -> 'b -type 'a comb_substitution = ('a, types list) substitution -type 'a type_substitution = ('a, types) substitution - -(* - * In an environment, substitute all subterms of a term that are - * convertible to a source term with a destination term. - * - * This checks convertibility before recursing, and so will replace at - * the highest level possible. - *) -val all_conv_substs : (types * types) type_substitution - -(* - * In an environment, substitute all subterms of a term that have - * a convertible type to the type of a source term with a - * destination term. - * - * This checks convertibility before recursing, and so will replace at - * the highest level possible. - *) -val all_typ_substs : (types * types) type_substitution - -(* - * In an environment, substitute all subterms of a term that apply a - * constructor with the first argument with the same type as the constructor. - * This effectively "undoes" the constructor. - * - * It's currently not smart enough to understand what to do when the - * constructor has multiple arguments of the same type as the type itself, - * like in tree-like inductive types. It's always going to try the left - * case in a tree for now. - * - * This checks convertibility before recursing, and so will replace at - * the highest level possible. - *) -val all_constr_substs : types type_substitution - -(* - * In an environment, return all combinations of substitutions of - * subterms of a term that are convertible with a source term - * with a destination term. - *) -val all_conv_substs_combs : (types * types) comb_substitution - -(* - * In an environment, return all combinations of substitutions of - * subterms of a term that have a type that is convertible with - * the type of a source term with a destination term. - *) -val all_typ_substs_combs : (types * types) comb_substitution diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index a98c83a..587763d 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -1,7 +1,5 @@ Utilities -Category - Coqterms Printing Hofs @@ -10,6 +8,8 @@ Substitution Filters Reducers +Category + Candidates Assumptions Merging From 7868f617c13db98b0da037a2b36c9b60e7358f4d Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 11:47:19 -0700 Subject: [PATCH 005/154] Fix build --- .gitignore | 1 + plugin/_CoqProject | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index bb51f12..ec833c5 100644 --- a/.gitignore +++ b/.gitignore @@ -2,6 +2,7 @@ plugin/*~ plugin/src/*~ plugin/*.coq.bak plugin/*.cmi +*.d *.ml4.d *.mli.d *.ml.d diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 4071b86..3150def 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,6 +1,6 @@ -I src/coq-plugin-lib/src/utilities --I src/library/categories --I src/library/coq +-I src/coq-plugin-lib/src/coq +-I src/categories -I src/library/proofsearch/representation -I src/library/proofsearch/compilation -I src/core/configuration From 4947955006fbd44236efe4a42b572ed5eff783a9 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 11:53:48 -0700 Subject: [PATCH 006/154] Refactor compilation stuff into categories --- plugin/_CoqProject | 48 +++++++++---------- .../compilation/evaluation.ml | 0 .../compilation/evaluation.mli | 0 .../compilation/expansion.ml | 0 .../compilation/expansion.mli | 0 .../compilation/proofdiff.ml | 0 .../compilation/proofdiff.mli | 0 .../compilation/zooming.ml | 0 .../compilation/zooming.mli | 0 .../representation/assumptions.ml | 0 .../representation/assumptions.mli | 0 .../representation/candidates.ml | 0 .../representation/candidates.mli | 0 .../representation/cutlemma.ml | 0 .../representation/cutlemma.mli | 0 .../representation/kindofchange.ml | 0 .../representation/kindofchange.mli | 0 .../representation/merging.ml | 0 .../representation/merging.mli | 0 .../representation/proofcat.ml | 0 .../representation/proofcat.mli | 0 .../representation/proofcatterms.ml | 0 .../representation/proofcatterms.mli | 0 23 files changed, 24 insertions(+), 24 deletions(-) rename plugin/src/{library/proofsearch => categories}/compilation/evaluation.ml (100%) rename plugin/src/{library/proofsearch => categories}/compilation/evaluation.mli (100%) rename plugin/src/{library/proofsearch => categories}/compilation/expansion.ml (100%) rename plugin/src/{library/proofsearch => categories}/compilation/expansion.mli (100%) rename plugin/src/{library/proofsearch => categories}/compilation/proofdiff.ml (100%) rename plugin/src/{library/proofsearch => categories}/compilation/proofdiff.mli (100%) rename plugin/src/{library/proofsearch => categories}/compilation/zooming.ml (100%) rename plugin/src/{library/proofsearch => categories}/compilation/zooming.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/assumptions.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/assumptions.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/candidates.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/candidates.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/cutlemma.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/cutlemma.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/kindofchange.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/kindofchange.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/merging.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/merging.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/proofcat.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/proofcat.mli (100%) rename plugin/src/{library/proofsearch => categories}/representation/proofcatterms.ml (100%) rename plugin/src/{library/proofsearch => categories}/representation/proofcatterms.mli (100%) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 3150def..110c8ab 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,8 +1,8 @@ -I src/coq-plugin-lib/src/utilities -I src/coq-plugin-lib/src/coq -I src/categories --I src/library/proofsearch/representation --I src/library/proofsearch/compilation +-I src/categories/representation +-I src/categories/compilation -I src/core/configuration -I src/core/components/abstraction -I src/core/components/specialization @@ -35,29 +35,29 @@ src/coq-plugin-lib/src/coq/reducers.ml src/categories/category.mli src/categories/category.ml -src/library/proofsearch/representation/candidates.mli -src/library/proofsearch/representation/candidates.ml -src/library/proofsearch/representation/assumptions.mli -src/library/proofsearch/representation/assumptions.ml -src/library/proofsearch/representation/merging.mli -src/library/proofsearch/representation/merging.ml -src/library/proofsearch/representation/proofcat.mli -src/library/proofsearch/representation/proofcat.ml -src/library/proofsearch/representation/proofcatterms.mli -src/library/proofsearch/representation/proofcatterms.ml -src/library/proofsearch/representation/cutlemma.mli -src/library/proofsearch/representation/cutlemma.ml -src/library/proofsearch/representation/kindofchange.mli -src/library/proofsearch/representation/kindofchange.ml +src/categories/representation/candidates.mli +src/categories/representation/candidates.ml +src/categories/representation/assumptions.mli +src/categories/representation/assumptions.ml +src/categories/representation/merging.mli +src/categories/representation/merging.ml +src/categories/representation/proofcat.mli +src/categories/representation/proofcat.ml +src/categories/representation/proofcatterms.mli +src/categories/representation/proofcatterms.ml +src/categories/representation/cutlemma.mli +src/categories/representation/cutlemma.ml +src/categories/representation/kindofchange.mli +src/categories/representation/kindofchange.ml -src/library/proofsearch/compilation/evaluation.mli -src/library/proofsearch/compilation/evaluation.ml -src/library/proofsearch/compilation/expansion.mli -src/library/proofsearch/compilation/expansion.ml -src/library/proofsearch/compilation/proofdiff.mli -src/library/proofsearch/compilation/proofdiff.ml -src/library/proofsearch/compilation/zooming.mli -src/library/proofsearch/compilation/zooming.ml +src/categories/compilation/evaluation.mli +src/categories/compilation/evaluation.ml +src/categories/compilation/expansion.mli +src/categories/compilation/expansion.ml +src/categories/compilation/proofdiff.mli +src/categories/compilation/proofdiff.ml +src/categories/compilation/zooming.mli +src/categories/compilation/zooming.ml src/core/configuration/searchopts.mli src/core/configuration/searchopts.ml diff --git a/plugin/src/library/proofsearch/compilation/evaluation.ml b/plugin/src/categories/compilation/evaluation.ml similarity index 100% rename from plugin/src/library/proofsearch/compilation/evaluation.ml rename to plugin/src/categories/compilation/evaluation.ml diff --git a/plugin/src/library/proofsearch/compilation/evaluation.mli b/plugin/src/categories/compilation/evaluation.mli similarity index 100% rename from plugin/src/library/proofsearch/compilation/evaluation.mli rename to plugin/src/categories/compilation/evaluation.mli diff --git a/plugin/src/library/proofsearch/compilation/expansion.ml b/plugin/src/categories/compilation/expansion.ml similarity index 100% rename from plugin/src/library/proofsearch/compilation/expansion.ml rename to plugin/src/categories/compilation/expansion.ml diff --git a/plugin/src/library/proofsearch/compilation/expansion.mli b/plugin/src/categories/compilation/expansion.mli similarity index 100% rename from plugin/src/library/proofsearch/compilation/expansion.mli rename to plugin/src/categories/compilation/expansion.mli diff --git a/plugin/src/library/proofsearch/compilation/proofdiff.ml b/plugin/src/categories/compilation/proofdiff.ml similarity index 100% rename from plugin/src/library/proofsearch/compilation/proofdiff.ml rename to plugin/src/categories/compilation/proofdiff.ml diff --git a/plugin/src/library/proofsearch/compilation/proofdiff.mli b/plugin/src/categories/compilation/proofdiff.mli similarity index 100% rename from plugin/src/library/proofsearch/compilation/proofdiff.mli rename to plugin/src/categories/compilation/proofdiff.mli diff --git a/plugin/src/library/proofsearch/compilation/zooming.ml b/plugin/src/categories/compilation/zooming.ml similarity index 100% rename from plugin/src/library/proofsearch/compilation/zooming.ml rename to plugin/src/categories/compilation/zooming.ml diff --git a/plugin/src/library/proofsearch/compilation/zooming.mli b/plugin/src/categories/compilation/zooming.mli similarity index 100% rename from plugin/src/library/proofsearch/compilation/zooming.mli rename to plugin/src/categories/compilation/zooming.mli diff --git a/plugin/src/library/proofsearch/representation/assumptions.ml b/plugin/src/categories/representation/assumptions.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/assumptions.ml rename to plugin/src/categories/representation/assumptions.ml diff --git a/plugin/src/library/proofsearch/representation/assumptions.mli b/plugin/src/categories/representation/assumptions.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/assumptions.mli rename to plugin/src/categories/representation/assumptions.mli diff --git a/plugin/src/library/proofsearch/representation/candidates.ml b/plugin/src/categories/representation/candidates.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/candidates.ml rename to plugin/src/categories/representation/candidates.ml diff --git a/plugin/src/library/proofsearch/representation/candidates.mli b/plugin/src/categories/representation/candidates.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/candidates.mli rename to plugin/src/categories/representation/candidates.mli diff --git a/plugin/src/library/proofsearch/representation/cutlemma.ml b/plugin/src/categories/representation/cutlemma.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/cutlemma.ml rename to plugin/src/categories/representation/cutlemma.ml diff --git a/plugin/src/library/proofsearch/representation/cutlemma.mli b/plugin/src/categories/representation/cutlemma.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/cutlemma.mli rename to plugin/src/categories/representation/cutlemma.mli diff --git a/plugin/src/library/proofsearch/representation/kindofchange.ml b/plugin/src/categories/representation/kindofchange.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/kindofchange.ml rename to plugin/src/categories/representation/kindofchange.ml diff --git a/plugin/src/library/proofsearch/representation/kindofchange.mli b/plugin/src/categories/representation/kindofchange.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/kindofchange.mli rename to plugin/src/categories/representation/kindofchange.mli diff --git a/plugin/src/library/proofsearch/representation/merging.ml b/plugin/src/categories/representation/merging.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/merging.ml rename to plugin/src/categories/representation/merging.ml diff --git a/plugin/src/library/proofsearch/representation/merging.mli b/plugin/src/categories/representation/merging.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/merging.mli rename to plugin/src/categories/representation/merging.mli diff --git a/plugin/src/library/proofsearch/representation/proofcat.ml b/plugin/src/categories/representation/proofcat.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/proofcat.ml rename to plugin/src/categories/representation/proofcat.ml diff --git a/plugin/src/library/proofsearch/representation/proofcat.mli b/plugin/src/categories/representation/proofcat.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/proofcat.mli rename to plugin/src/categories/representation/proofcat.mli diff --git a/plugin/src/library/proofsearch/representation/proofcatterms.ml b/plugin/src/categories/representation/proofcatterms.ml similarity index 100% rename from plugin/src/library/proofsearch/representation/proofcatterms.ml rename to plugin/src/categories/representation/proofcatterms.ml diff --git a/plugin/src/library/proofsearch/representation/proofcatterms.mli b/plugin/src/categories/representation/proofcatterms.mli similarity index 100% rename from plugin/src/library/proofsearch/representation/proofcatterms.mli rename to plugin/src/categories/representation/proofcatterms.mli From e3d46c6c3000131f198ed7a8219983ead4f4f3f1 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 11:59:20 -0700 Subject: [PATCH 007/154] Move compilation out --- plugin/_CoqProject | 54 +++++++++---------- .../compilation/evaluation.ml | 0 .../compilation/evaluation.mli | 0 .../{categories => }/compilation/expansion.ml | 0 .../compilation/expansion.mli | 0 .../{categories => }/compilation/proofdiff.ml | 0 .../compilation/proofdiff.mli | 0 .../{categories => }/compilation/zooming.ml | 0 .../{categories => }/compilation/zooming.mli | 0 .../representation/assumptions.ml | 0 .../representation/assumptions.mli | 0 .../representation/candidates.ml | 0 .../representation/candidates.mli | 0 .../categories/category.ml | 0 .../categories/category.mli | 0 .../representation/cutlemma.ml | 0 .../representation/cutlemma.mli | 0 .../representation/kindofchange.ml | 0 .../representation/kindofchange.mli | 0 .../representation/merging.ml | 0 .../representation/merging.mli | 0 .../representation/proofcat.ml | 0 .../representation/proofcat.mli | 0 .../representation/proofcatterms.ml | 0 .../representation/proofcatterms.mli | 0 25 files changed, 27 insertions(+), 27 deletions(-) rename plugin/src/{categories => }/compilation/evaluation.ml (100%) rename plugin/src/{categories => }/compilation/evaluation.mli (100%) rename plugin/src/{categories => }/compilation/expansion.ml (100%) rename plugin/src/{categories => }/compilation/expansion.mli (100%) rename plugin/src/{categories => }/compilation/proofdiff.ml (100%) rename plugin/src/{categories => }/compilation/proofdiff.mli (100%) rename plugin/src/{categories => }/compilation/zooming.ml (100%) rename plugin/src/{categories => }/compilation/zooming.mli (100%) rename plugin/src/{categories => }/representation/assumptions.ml (100%) rename plugin/src/{categories => }/representation/assumptions.mli (100%) rename plugin/src/{categories => }/representation/candidates.ml (100%) rename plugin/src/{categories => }/representation/candidates.mli (100%) rename plugin/src/{ => representation}/categories/category.ml (100%) rename plugin/src/{ => representation}/categories/category.mli (100%) rename plugin/src/{categories => }/representation/cutlemma.ml (100%) rename plugin/src/{categories => }/representation/cutlemma.mli (100%) rename plugin/src/{categories => }/representation/kindofchange.ml (100%) rename plugin/src/{categories => }/representation/kindofchange.mli (100%) rename plugin/src/{categories => }/representation/merging.ml (100%) rename plugin/src/{categories => }/representation/merging.mli (100%) rename plugin/src/{categories => }/representation/proofcat.ml (100%) rename plugin/src/{categories => }/representation/proofcat.mli (100%) rename plugin/src/{categories => }/representation/proofcatterms.ml (100%) rename plugin/src/{categories => }/representation/proofcatterms.mli (100%) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 110c8ab..a48a9c3 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,8 +1,8 @@ -I src/coq-plugin-lib/src/utilities -I src/coq-plugin-lib/src/coq --I src/categories --I src/categories/representation --I src/categories/compilation +-I src/representation +-I src/representation/categories +-I src/compilation -I src/core/configuration -I src/core/components/abstraction -I src/core/components/specialization @@ -32,32 +32,32 @@ src/coq-plugin-lib/src/coq/filters.ml src/coq-plugin-lib/src/coq/reducers.mli src/coq-plugin-lib/src/coq/reducers.ml -src/categories/category.mli -src/categories/category.ml +src/representation/categories/category.mli +src/representation/categories/category.ml -src/categories/representation/candidates.mli -src/categories/representation/candidates.ml -src/categories/representation/assumptions.mli -src/categories/representation/assumptions.ml -src/categories/representation/merging.mli -src/categories/representation/merging.ml -src/categories/representation/proofcat.mli -src/categories/representation/proofcat.ml -src/categories/representation/proofcatterms.mli -src/categories/representation/proofcatterms.ml -src/categories/representation/cutlemma.mli -src/categories/representation/cutlemma.ml -src/categories/representation/kindofchange.mli -src/categories/representation/kindofchange.ml +src/representation/candidates.mli +src/representation/candidates.ml +src/representation/assumptions.mli +src/representation/assumptions.ml +src/representation/merging.mli +src/representation/merging.ml +src/representation/proofcat.mli +src/representation/proofcat.ml +src/representation/proofcatterms.mli +src/representation/proofcatterms.ml +src/representation/cutlemma.mli +src/representation/cutlemma.ml +src/representation/kindofchange.mli +src/representation/kindofchange.ml -src/categories/compilation/evaluation.mli -src/categories/compilation/evaluation.ml -src/categories/compilation/expansion.mli -src/categories/compilation/expansion.ml -src/categories/compilation/proofdiff.mli -src/categories/compilation/proofdiff.ml -src/categories/compilation/zooming.mli -src/categories/compilation/zooming.ml +src/compilation/evaluation.mli +src/compilation/evaluation.ml +src/compilation/expansion.mli +src/compilation/expansion.ml +src/compilation/proofdiff.mli +src/compilation/proofdiff.ml +src/compilation/zooming.mli +src/compilation/zooming.ml src/core/configuration/searchopts.mli src/core/configuration/searchopts.ml diff --git a/plugin/src/categories/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml similarity index 100% rename from plugin/src/categories/compilation/evaluation.ml rename to plugin/src/compilation/evaluation.ml diff --git a/plugin/src/categories/compilation/evaluation.mli b/plugin/src/compilation/evaluation.mli similarity index 100% rename from plugin/src/categories/compilation/evaluation.mli rename to plugin/src/compilation/evaluation.mli diff --git a/plugin/src/categories/compilation/expansion.ml b/plugin/src/compilation/expansion.ml similarity index 100% rename from plugin/src/categories/compilation/expansion.ml rename to plugin/src/compilation/expansion.ml diff --git a/plugin/src/categories/compilation/expansion.mli b/plugin/src/compilation/expansion.mli similarity index 100% rename from plugin/src/categories/compilation/expansion.mli rename to plugin/src/compilation/expansion.mli diff --git a/plugin/src/categories/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml similarity index 100% rename from plugin/src/categories/compilation/proofdiff.ml rename to plugin/src/compilation/proofdiff.ml diff --git a/plugin/src/categories/compilation/proofdiff.mli b/plugin/src/compilation/proofdiff.mli similarity index 100% rename from plugin/src/categories/compilation/proofdiff.mli rename to plugin/src/compilation/proofdiff.mli diff --git a/plugin/src/categories/compilation/zooming.ml b/plugin/src/compilation/zooming.ml similarity index 100% rename from plugin/src/categories/compilation/zooming.ml rename to plugin/src/compilation/zooming.ml diff --git a/plugin/src/categories/compilation/zooming.mli b/plugin/src/compilation/zooming.mli similarity index 100% rename from plugin/src/categories/compilation/zooming.mli rename to plugin/src/compilation/zooming.mli diff --git a/plugin/src/categories/representation/assumptions.ml b/plugin/src/representation/assumptions.ml similarity index 100% rename from plugin/src/categories/representation/assumptions.ml rename to plugin/src/representation/assumptions.ml diff --git a/plugin/src/categories/representation/assumptions.mli b/plugin/src/representation/assumptions.mli similarity index 100% rename from plugin/src/categories/representation/assumptions.mli rename to plugin/src/representation/assumptions.mli diff --git a/plugin/src/categories/representation/candidates.ml b/plugin/src/representation/candidates.ml similarity index 100% rename from plugin/src/categories/representation/candidates.ml rename to plugin/src/representation/candidates.ml diff --git a/plugin/src/categories/representation/candidates.mli b/plugin/src/representation/candidates.mli similarity index 100% rename from plugin/src/categories/representation/candidates.mli rename to plugin/src/representation/candidates.mli diff --git a/plugin/src/categories/category.ml b/plugin/src/representation/categories/category.ml similarity index 100% rename from plugin/src/categories/category.ml rename to plugin/src/representation/categories/category.ml diff --git a/plugin/src/categories/category.mli b/plugin/src/representation/categories/category.mli similarity index 100% rename from plugin/src/categories/category.mli rename to plugin/src/representation/categories/category.mli diff --git a/plugin/src/categories/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml similarity index 100% rename from plugin/src/categories/representation/cutlemma.ml rename to plugin/src/representation/cutlemma.ml diff --git a/plugin/src/categories/representation/cutlemma.mli b/plugin/src/representation/cutlemma.mli similarity index 100% rename from plugin/src/categories/representation/cutlemma.mli rename to plugin/src/representation/cutlemma.mli diff --git a/plugin/src/categories/representation/kindofchange.ml b/plugin/src/representation/kindofchange.ml similarity index 100% rename from plugin/src/categories/representation/kindofchange.ml rename to plugin/src/representation/kindofchange.ml diff --git a/plugin/src/categories/representation/kindofchange.mli b/plugin/src/representation/kindofchange.mli similarity index 100% rename from plugin/src/categories/representation/kindofchange.mli rename to plugin/src/representation/kindofchange.mli diff --git a/plugin/src/categories/representation/merging.ml b/plugin/src/representation/merging.ml similarity index 100% rename from plugin/src/categories/representation/merging.ml rename to plugin/src/representation/merging.ml diff --git a/plugin/src/categories/representation/merging.mli b/plugin/src/representation/merging.mli similarity index 100% rename from plugin/src/categories/representation/merging.mli rename to plugin/src/representation/merging.mli diff --git a/plugin/src/categories/representation/proofcat.ml b/plugin/src/representation/proofcat.ml similarity index 100% rename from plugin/src/categories/representation/proofcat.ml rename to plugin/src/representation/proofcat.ml diff --git a/plugin/src/categories/representation/proofcat.mli b/plugin/src/representation/proofcat.mli similarity index 100% rename from plugin/src/categories/representation/proofcat.mli rename to plugin/src/representation/proofcat.mli diff --git a/plugin/src/categories/representation/proofcatterms.ml b/plugin/src/representation/proofcatterms.ml similarity index 100% rename from plugin/src/categories/representation/proofcatterms.ml rename to plugin/src/representation/proofcatterms.ml diff --git a/plugin/src/categories/representation/proofcatterms.mli b/plugin/src/representation/proofcatterms.mli similarity index 100% rename from plugin/src/categories/representation/proofcatterms.mli rename to plugin/src/representation/proofcatterms.mli From f0030aecfaba31b978f048d597ac7cd43da9f55b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 13:06:02 -0700 Subject: [PATCH 008/154] refactor some files --- plugin/_CoqProject | 10 +++++----- .../{representation => configuration}/kindofchange.ml | 0 .../{representation => configuration}/kindofchange.mli | 0 plugin/src/{core => }/configuration/searchopts.ml | 0 plugin/src/{core => }/configuration/searchopts.mli | 0 plugin/src/patch.mlpack | 2 +- 6 files changed, 6 insertions(+), 6 deletions(-) rename plugin/src/{representation => configuration}/kindofchange.ml (100%) rename plugin/src/{representation => configuration}/kindofchange.mli (100%) rename plugin/src/{core => }/configuration/searchopts.ml (100%) rename plugin/src/{core => }/configuration/searchopts.mli (100%) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index a48a9c3..fa34784 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -2,8 +2,8 @@ -I src/coq-plugin-lib/src/coq -I src/representation -I src/representation/categories +-I src/configuration -I src/compilation --I src/core/configuration -I src/core/components/abstraction -I src/core/components/specialization -I src/core/components/inversion @@ -47,8 +47,6 @@ src/representation/proofcatterms.mli src/representation/proofcatterms.ml src/representation/cutlemma.mli src/representation/cutlemma.ml -src/representation/kindofchange.mli -src/representation/kindofchange.ml src/compilation/evaluation.mli src/compilation/evaluation.ml @@ -59,8 +57,10 @@ src/compilation/proofdiff.ml src/compilation/zooming.mli src/compilation/zooming.ml -src/core/configuration/searchopts.mli -src/core/configuration/searchopts.ml +src/configuration/kindofchange.mli +src/configuration/kindofchange.ml +src/configuration/searchopts.mli +src/configuration/searchopts.ml src/core/components/specialization/specialization.mli src/core/components/specialization/specialization.ml diff --git a/plugin/src/representation/kindofchange.ml b/plugin/src/configuration/kindofchange.ml similarity index 100% rename from plugin/src/representation/kindofchange.ml rename to plugin/src/configuration/kindofchange.ml diff --git a/plugin/src/representation/kindofchange.mli b/plugin/src/configuration/kindofchange.mli similarity index 100% rename from plugin/src/representation/kindofchange.mli rename to plugin/src/configuration/kindofchange.mli diff --git a/plugin/src/core/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml similarity index 100% rename from plugin/src/core/configuration/searchopts.ml rename to plugin/src/configuration/searchopts.ml diff --git a/plugin/src/core/configuration/searchopts.mli b/plugin/src/configuration/searchopts.mli similarity index 100% rename from plugin/src/core/configuration/searchopts.mli rename to plugin/src/configuration/searchopts.mli diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index 587763d..109a6ab 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -16,13 +16,13 @@ Merging Proofcat Proofcatterms Cutlemma -Kindofchange Evaluation Expansion Proofdiff Zooming +Kindofchange Searchopts Specialization From 743de3ad9ef13e71b633ef809e44a1ed459a538b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 13:10:55 -0700 Subject: [PATCH 009/154] move category stuff into one directory for later refactor --- plugin/_CoqProject | 14 +++++++------- plugin/src/patch.mlpack | 6 +++--- .../representation/{ => categories}/proofcat.ml | 0 .../representation/{ => categories}/proofcat.mli | 0 .../{ => categories}/proofcatterms.ml | 0 .../{ => categories}/proofcatterms.mli | 0 6 files changed, 10 insertions(+), 10 deletions(-) rename plugin/src/representation/{ => categories}/proofcat.ml (100%) rename plugin/src/representation/{ => categories}/proofcat.mli (100%) rename plugin/src/representation/{ => categories}/proofcatterms.ml (100%) rename plugin/src/representation/{ => categories}/proofcatterms.mli (100%) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index fa34784..02bdf38 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -32,22 +32,22 @@ src/coq-plugin-lib/src/coq/filters.ml src/coq-plugin-lib/src/coq/reducers.mli src/coq-plugin-lib/src/coq/reducers.ml -src/representation/categories/category.mli -src/representation/categories/category.ml - src/representation/candidates.mli src/representation/candidates.ml src/representation/assumptions.mli src/representation/assumptions.ml src/representation/merging.mli src/representation/merging.ml -src/representation/proofcat.mli -src/representation/proofcat.ml -src/representation/proofcatterms.mli -src/representation/proofcatterms.ml src/representation/cutlemma.mli src/representation/cutlemma.ml +src/representation/categories/category.mli +src/representation/categories/category.ml +src/representation/categories/proofcat.mli +src/representation/categories/proofcat.ml +src/representation/categories/proofcatterms.mli +src/representation/categories/proofcatterms.ml + src/compilation/evaluation.mli src/compilation/evaluation.ml src/compilation/expansion.mli diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index 109a6ab..d8632b8 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -8,14 +8,14 @@ Substitution Filters Reducers -Category - Candidates Assumptions Merging +Cutlemma + +Category Proofcat Proofcatterms -Cutlemma Evaluation Expansion diff --git a/plugin/src/representation/proofcat.ml b/plugin/src/representation/categories/proofcat.ml similarity index 100% rename from plugin/src/representation/proofcat.ml rename to plugin/src/representation/categories/proofcat.ml diff --git a/plugin/src/representation/proofcat.mli b/plugin/src/representation/categories/proofcat.mli similarity index 100% rename from plugin/src/representation/proofcat.mli rename to plugin/src/representation/categories/proofcat.mli diff --git a/plugin/src/representation/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml similarity index 100% rename from plugin/src/representation/proofcatterms.ml rename to plugin/src/representation/categories/proofcatterms.ml diff --git a/plugin/src/representation/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli similarity index 100% rename from plugin/src/representation/proofcatterms.mli rename to plugin/src/representation/categories/proofcatterms.mli From 0c7f65829777d2e66cc20b941f1ae7dec5c5df7d Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 13:28:11 -0700 Subject: [PATCH 010/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 9d7169a..ccd1910 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 9d7169a92d7b04318f914cc51293c86407d9c8aa +Subproject commit ccd19109a63e32bfe25f0365a805e1eba56e1062 From bc8eeddd6281d0d93f1ba259903c8f52f18f1766 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 13:36:45 -0700 Subject: [PATCH 011/154] work around name collision for now --- plugin/src/core/components/differencing/appdifferencers.ml | 4 ++-- plugin/src/core/procedures/search.ml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 0437ae2..ab34db6 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -1,13 +1,13 @@ (* --- Recursive Differencers for Application --- *) +open Utilities open Constr open Proofcatterms open Proofdiff open Candidates open Searchopts -open Coqterms open Evd -open Utilities +open Coqterms open Proofdifferencers open Higherdifferencers open Assumptions diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index 683bac3..99bc852 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -1,5 +1,6 @@ (* Search procedures *) +open Utilities open Environ open Constr open Assumptions @@ -8,7 +9,6 @@ open Abstractionconfig open Proofdiff open Reducers open Specialization -open Utilities open Inverting open Searchopts open Factoring From 17f67d5c48e3c269a035c10bb2fc4e8657cb5c37 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 16:23:51 -0700 Subject: [PATCH 012/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index ccd1910..60de3a7 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit ccd19109a63e32bfe25f0365a805e1eba56e1062 +Subproject commit 60de3a7cde5c314c7fdb013a243cc5abbdff30e8 From fd568fe6c2984face1375622953ab8a0d0d58b1a Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 16:34:51 -0700 Subject: [PATCH 013/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 60de3a7..eddecaa 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 60de3a7cde5c314c7fdb013a243cc5abbdff30e8 +Subproject commit eddecaa7233792873160213edb7230c39db54393 From 1e24f1442657d2f0fd301a9d6d7e501e7d9ca8d2 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 23 Jul 2019 16:45:24 -0700 Subject: [PATCH 014/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index eddecaa..e21da45 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit eddecaa7233792873160213edb7230c39db54393 +Subproject commit e21da4556d0157d0b6f3b16f4ad0980cd46a7268 From bca51c08c5b2246d6f50328e511fc581ee91bbb7 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 10:23:26 -0700 Subject: [PATCH 015/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index e21da45..caa30ed 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit e21da4556d0157d0b6f3b16f4ad0980cd46a7268 +Subproject commit caa30eda732b7e47d124ab0365f1cc3c223843df From 6fcd4798b5bcf7c9fb3079a3083dd5a0ca552752 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 10:38:45 -0700 Subject: [PATCH 016/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index caa30ed..ed80519 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit caa30eda732b7e47d124ab0365f1cc3c223843df +Subproject commit ed80519bce3304d4c1574fa762080d2367ad86c7 From 0cf7d68714574430555ffba097e7311f31a8d0e7 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 10:59:16 -0700 Subject: [PATCH 017/154] Update coq-plugin-lib with DEVOID debruijn functions --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index ed80519..4ebcba5 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit ed80519bce3304d4c1574fa762080d2367ad86c7 +Subproject commit 4ebcba5a341dd168c901725575d424e92f7f8e0e From cde3eeac909f668dc97ce1ae678b7a5f836c9636 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 11:10:08 -0700 Subject: [PATCH 018/154] update coq-plugin-lib with zooming functions --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 4ebcba5..7098c33 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 4ebcba5a341dd168c901725575d424e92f7f8e0e +Subproject commit 7098c337e364490d2b5a86a5a1ff0b911514e525 From f79d63c235feed74734cd33c7425611dcf18c21c Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 11:15:41 -0700 Subject: [PATCH 019/154] separate out category zooming from term zooming --- plugin/_CoqProject | 7 +- .../{zooming.ml => categories/catzooming.ml} | 95 ------------------- .../catzooming.mli} | 32 ------- plugin/src/configuration/searchopts.ml | 2 +- plugin/src/configuration/searchopts.mli | 2 +- .../differencing/appdifferencers.ml | 1 + .../components/differencing/differencing.ml | 2 +- .../differencing/inddifferencers.ml | 1 + plugin/src/patch.mlpack | 3 +- 9 files changed, 12 insertions(+), 133 deletions(-) rename plugin/src/compilation/{zooming.ml => categories/catzooming.ml} (60%) rename plugin/src/compilation/{zooming.mli => categories/catzooming.mli} (72%) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 02bdf38..9259d39 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -4,6 +4,7 @@ -I src/representation/categories -I src/configuration -I src/compilation +-I src/compilation/categories -I src/core/components/abstraction -I src/core/components/specialization -I src/core/components/inversion @@ -25,6 +26,8 @@ src/coq-plugin-lib/src/coq/hofs.mli src/coq-plugin-lib/src/coq/hofs.ml src/coq-plugin-lib/src/coq/debruijn.mli src/coq-plugin-lib/src/coq/debruijn.ml +src/coq-plugin-lib/src/coq/zooming.mli +src/coq-plugin-lib/src/coq/zooming.ml src/coq-plugin-lib/src/coq/substitution.mli src/coq-plugin-lib/src/coq/substitution.ml src/coq-plugin-lib/src/coq/filters.mli @@ -54,8 +57,8 @@ src/compilation/expansion.mli src/compilation/expansion.ml src/compilation/proofdiff.mli src/compilation/proofdiff.ml -src/compilation/zooming.mli -src/compilation/zooming.ml +src/compilation/categories/catzooming.mli +src/compilation/categories/catzooming.ml src/configuration/kindofchange.mli src/configuration/kindofchange.ml diff --git a/plugin/src/compilation/zooming.ml b/plugin/src/compilation/categories/catzooming.ml similarity index 60% rename from plugin/src/compilation/zooming.ml rename to plugin/src/compilation/categories/catzooming.ml index 622ed41..38ce13c 100644 --- a/plugin/src/compilation/zooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -164,98 +164,3 @@ let zoom_unshift f (d : goal_proof_diff) : candidates = zoom_search (fun d -> List.map unshift (f d)) d - -(* --- Zoomers on terms, instead of proof categories --- *) - -(* Zoom into a term *) -let rec zoom_n_prod env npm typ : env * types = - if npm = 0 then - (env, typ) - else - match kind typ with - | Prod (n1, t1, b1) -> - zoom_n_prod (push_local (n1, t1) env) (npm - 1) b1 - | _ -> - failwith "more parameters expected" - -(* Lambda version *) -let zoom_n_lambda env npm trm : env * types = - let (env, typ) = zoom_n_prod env npm (lambda_to_prod trm) in - (env, prod_to_lambda typ) - -(* Zoom all the way into a lambda term *) -let rec zoom_lambda_term (env : env) (trm : types) : env * types = - match kind trm with - | Lambda (n, t, b) -> - zoom_lambda_term (push_local (n, t) env) b - | _ -> - (env, trm) - -(* Zoom all the way into a product type *) -let rec zoom_product_type (env : env) (typ : types) : env * types = - match kind typ with - | Prod (n, t, b) -> - zoom_product_type (push_local (n, t) env) b - | _ -> - (env, typ) - -(* Zoom into the environment *) -let zoom_env zoom (env : env) (trm : types) : env = - fst (zoom env trm) - -(* Zoom into the term *) -let zoom_term zoom (env : env) (trm : types) : types = - snd (zoom env trm) - -(* --- Reconstruction after zooming into terms --- *) - -(* Reconstruct a lambda from an environment, but stop when i are left *) -let rec reconstruct_lambda_n (env : env) (b : types) (i : int) : types = - if nb_rel env = i then - b - else - let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in - let env' = pop_rel_context 1 env in - reconstruct_lambda_n env' (mkLambda (n, t, b)) i - -(* Reconstruct a lambda from an environment *) -let reconstruct_lambda (env : env) (b : types) : types = - reconstruct_lambda_n env b 0 - -(* Like reconstruct_lambda_n, but first skip j elements *) -let rec reconstruct_lambda_n_skip (env : env) (b : types) (i : int) (j : int) : types = - if nb_rel env = i then - b - else - let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in - let env' = pop_rel_context 1 env in - if j <= 0 then - reconstruct_lambda_n_skip env' (mkLambda (n, t, b)) i j - else - reconstruct_lambda_n_skip env' (unshift b) (i - 1) (j - 1) - - -(* Reconstruct a product from an environment, but stop when i are left *) -let rec reconstruct_product_n (env : env) (b : types) (i : int) : types = - if nb_rel env = i then - b - else - let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in - let env' = pop_rel_context 1 env in - reconstruct_product_n env' (mkProd (n, t, b)) i - -(* Reconstruct a product from an environment *) -let reconstruct_product (env : env) (b : types) : types = - reconstruct_product_n env b 0 - -(* Like reconstruct_product_n, but first skip j elements *) -let rec reconstruct_product_n_skip (env : env) (b : types) (i : int) (j : int) : types = - if nb_rel env = i then - b - else - let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in - let env' = pop_rel_context 1 env in - if j <= 0 then - reconstruct_product_n_skip env' (mkProd (n, t, b)) i j - else - reconstruct_product_n_skip env' (unshift b) (i - 1) (j - 1) diff --git a/plugin/src/compilation/zooming.mli b/plugin/src/compilation/categories/catzooming.mli similarity index 72% rename from plugin/src/compilation/zooming.mli rename to plugin/src/compilation/categories/catzooming.mli index 3d6f4e7..374facd 100644 --- a/plugin/src/compilation/zooming.mli +++ b/plugin/src/compilation/categories/catzooming.mli @@ -127,35 +127,3 @@ val zoom_wrap_prod : *) val zoom_unshift : search_function -> goal_proof_diff -> candidates -(* --- Zooming into terms, rather than proof categories --- *) - -(* - * We will soon move away from the proof category representation, since - * it makes the code difficult to maintain and understand. These functions - * help with that transition by allowing is to zoom directly into terms. - *) - -(* Zoom n deep *) -val zoom_n_prod : env -> int -> types -> (env * types) -val zoom_n_lambda : env -> int -> types -> (env * types) - -(* Zoom all the way *) -val zoom_lambda_term : env -> types -> (env * types) -val zoom_product_type : env -> types -> (env * types) - -(* Projections of zooming *) -val zoom_env : (env -> types -> (env * types)) -> env -> types -> env -val zoom_term : (env -> types -> (env * types)) -> env -> types -> types -(* --- Reconstruction after zooming into terms --- *) - -(* Reconstruct until n are left *) -val reconstruct_lambda_n : env -> types -> int -> types -val reconstruct_product_n : env -> types -> int -> types - -(* Reconstruct until n are left, skipping a given amount first *) -val reconstruct_lambda_n_skip : env -> types -> int -> int -> types -val reconstruct_product_n_skip : env -> types -> int -> int -> types - -(* Reconstruct fully *) -val reconstruct_lambda : env -> types -> types -val reconstruct_product : env -> types -> types diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index 2a684e4..dff8bcf 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -11,7 +11,7 @@ open Proofdiff open Assumptions open Kindofchange open Cutlemma -open Zooming +open Catzooming module CRD = Context.Rel.Declaration diff --git a/plugin/src/configuration/searchopts.mli b/plugin/src/configuration/searchopts.mli index 1998e51..a688756 100644 --- a/plugin/src/configuration/searchopts.mli +++ b/plugin/src/configuration/searchopts.mli @@ -5,7 +5,7 @@ open Proofdiff open Cutlemma open Kindofchange open Candidates -open Zooming +open Catzooming (* --- Options for search --- *) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index ab34db6..17cc203 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -14,6 +14,7 @@ open Assumptions open Cutlemma open Specialization open Zooming +open Catzooming open Debruijn open Filters diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index 22d4f3e..b47885b 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -7,7 +7,7 @@ open Reducers open Candidates open Kindofchange open Printing -open Zooming +open Catzooming open Proofdifferencers open Higherdifferencers open Appdifferencers diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index c5ca67f..3eeab62 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -7,6 +7,7 @@ open Proofcatterms open Proofdiff open Candidates open Evaluation +open Catzooming open Zooming open Debruijn open Kindofchange diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index d8632b8..ce37137 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -4,6 +4,7 @@ Coqterms Printing Hofs Debruijn +Zooming Substitution Filters Reducers @@ -20,7 +21,7 @@ Proofcatterms Evaluation Expansion Proofdiff -Zooming +Catzooming Kindofchange Searchopts From 59e3535a8c9ec880479948e1abefe1d883456368 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:21:00 -0700 Subject: [PATCH 020/154] update coq-plugin-lib with DEVOID substitution --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 7098c33..3dd77bb 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 7098c337e364490d2b5a86a5a1ff0b911514e525 +Subproject commit 3dd77bbe135b7b21f51352b92ebd2e5d21fbcd0a From 2edf311ff73a459b3b1969491dae8282324b295b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:22:22 -0700 Subject: [PATCH 021/154] fix build --- plugin/_CoqProject | 4 ++-- plugin/src/patch.mlpack | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 9259d39..a79b8c4 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -22,10 +22,10 @@ src/coq-plugin-lib/src/coq/coqterms.mli src/coq-plugin-lib/src/coq/coqterms.ml src/coq-plugin-lib/src/coq/printing.mli src/coq-plugin-lib/src/coq/printing.ml -src/coq-plugin-lib/src/coq/hofs.mli -src/coq-plugin-lib/src/coq/hofs.ml src/coq-plugin-lib/src/coq/debruijn.mli src/coq-plugin-lib/src/coq/debruijn.ml +src/coq-plugin-lib/src/coq/hofs.mli +src/coq-plugin-lib/src/coq/hofs.ml src/coq-plugin-lib/src/coq/zooming.mli src/coq-plugin-lib/src/coq/zooming.ml src/coq-plugin-lib/src/coq/substitution.mli diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index ce37137..d9c23a1 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -2,8 +2,8 @@ Utilities Coqterms Printing -Hofs Debruijn +Hofs Zooming Substitution Filters From de19710e0309e35c60f1b66626aab923482deb8f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:34:03 -0700 Subject: [PATCH 022/154] update convertibility in lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 3dd77bb..861dafa 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 3dd77bbe135b7b21f51352b92ebd2e5d21fbcd0a +Subproject commit 861dafa59f8dea6c16b47efbc8086923db60bdc9 From 7e650d17dacac0e3016fcda0f36904a392d1983b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:46:36 -0700 Subject: [PATCH 023/154] use better infer_type function --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 861dafa..754e450 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 861dafa59f8dea6c16b47efbc8086923db60bdc9 +Subproject commit 754e45010f991061bcd9eff519e6fb4dec862078 From e154cad2e2cde6b1f7b8cd76ac56e67a8b3b0b9b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:55:33 -0700 Subject: [PATCH 024/154] update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 754e450..b7ca334 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 754e45010f991061bcd9eff519e6fb4dec862078 +Subproject commit b7ca33486a8980754b04d3b925a53d9d5e8a1b5c From 8e8ffc64ff9e003efc1e1a6068a9d895ed09b157 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:57:56 -0700 Subject: [PATCH 025/154] more backwards compatibility --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index b7ca334..2b34af9 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit b7ca33486a8980754b04d3b925a53d9d5e8a1b5c +Subproject commit 2b34af992b3ce0e79828631ec771e0cb6243c732 From c31b21f841d180c2f86c1aeb11a774745e94bca7 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 12:59:47 -0700 Subject: [PATCH 026/154] backwards compatibility for infer_type --- plugin/src/compilation/evaluation.ml | 13 ++++++++++++ plugin/src/compilation/expansion.ml | 20 +++++++++++++++++++ .../components/abstraction/abstraction.ml | 13 ++++++++++++ .../abstraction/abstractionconfig.ml | 13 ++++++++++++ .../differencing/proofdifferencers.ml | 14 +++++++++++++ .../core/components/inversion/inverting.ml | 13 ++++++++++++ plugin/src/core/procedures/theorem.ml | 13 ++++++++++++ plugin/src/patcher.ml4 | 14 +++++++++++++ plugin/src/representation/cutlemma.ml | 13 ++++++++++++ 9 files changed, 126 insertions(+) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index f9d5e1b..5bb5599 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -13,6 +13,19 @@ open Declarations module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* * Note: Evar discipline is not good yet, but should wait until after * the major refactor, since this will change a lot. diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 11fa314..a58a8c7 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -14,6 +14,26 @@ open Declarations module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* Check whether a term has a given type *) +let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool = + try + let trm_typ = infer_type env evd trm in + convertible env evd trm_typ typ + with _ -> false + +(* --- End TODO --- *) + (* --- Type definitions --- *) type 'a expansion_strategy = 'a -> 'a diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 344dee8..6a510f4 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -20,6 +20,19 @@ open Zooming module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* Internal options for abstraction *) type abstraction_options = { diff --git a/plugin/src/core/components/abstraction/abstractionconfig.ml b/plugin/src/core/components/abstraction/abstractionconfig.ml index fc39bcc..ad12271 100644 --- a/plugin/src/core/components/abstraction/abstractionconfig.ml +++ b/plugin/src/core/components/abstraction/abstractionconfig.ml @@ -11,6 +11,19 @@ open Cutlemma module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* --- Configuring Abstraction --- *) (* Caller configuration for abstraction *) diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index bf1e6c5..9b635fa 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -8,6 +8,7 @@ open Searchopts open Substitution open Proofdiff open Debruijn +open Evd open Filters open Candidates open Reducers @@ -17,6 +18,19 @@ open Zooming module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* --- Utilities --- *) (* diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 90290e1..5b3ba2b 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -17,6 +17,19 @@ module CRD = Context.Rel.Declaration type inverter = evar_map -> (env * types) -> (env * types) option +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* --- Inverting type paths --- *) (* diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 361bc57..3d88748 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -12,6 +12,19 @@ open Zooming module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* * Zoom all the way into a lambda term * diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 350ced7..b87b9b3 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -9,6 +9,7 @@ open Assumptions open Evaluation open Proofdiff open Search +open Evd open Printing open Inverting open Theorem @@ -28,6 +29,19 @@ open Zooming module Globmap = Globnames.Refmap +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + (* * Plugin for patching Coq proofs given a change. * diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index cdcad1b..baab5dd 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -10,6 +10,19 @@ open Utilities module CRD = Context.Rel.Declaration +(* --- TODO for refactoring without breaking things --- *) + +(* + * Infer the type of trm in env + * Note: This does not yet use good evar map hygeine; will fix that + * during the refactor. + *) +let infer_type (env : env) (evd : evar_map) (trm : types) : types = + let jmt = Typeops.infer env trm in + j_type jmt + +(* --- End TODO --- *) + type cut_lemma = { lemma : types; From 34ab0bf9b24431d0ba8b660034fd2c907faf7494 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 13:10:04 -0700 Subject: [PATCH 027/154] bug fixes from DEVOID printing --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 2b34af9..9aa4616 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 2b34af992b3ce0e79828631ec771e0cb6243c732 +Subproject commit 9aa46161616b4d4044a099312d5f9a2d02f7db25 From b9ce6a495a9935aab1a89a56d7a7406a2e4f1b45 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 13:17:05 -0700 Subject: [PATCH 028/154] finish DEVOID lib refactor --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 9aa4616..de8dcc7 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 9aa46161616b4d4044a099312d5f9a2d02f7db25 +Subproject commit de8dcc7e93ea3198fde8cf976247579983d1587f From 64740416fb490392ca9298927accc1164d00c750 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 24 Jul 2019 17:19:41 -0700 Subject: [PATCH 029/154] Move fixpoint translation into different repository (silly build process for now) --- .gitmodules | 3 + plugin/_CoqProject | 2 - plugin/build.sh | 5 + plugin/coq/Preprocess.v | 1871 ------------------------ plugin/coq/PreprocessModule.v | 15 - plugin/deps/fix-to-elim | 1 + plugin/src/core/procedures/desugar.ml | 408 ------ plugin/src/core/procedures/desugar.mli | 11 - plugin/src/patcher.ml4 | 51 - plugin/theories/Patch.v | 2 + 10 files changed, 11 insertions(+), 2358 deletions(-) delete mode 100644 plugin/coq/Preprocess.v delete mode 100644 plugin/coq/PreprocessModule.v create mode 160000 plugin/deps/fix-to-elim delete mode 100644 plugin/src/core/procedures/desugar.ml delete mode 100644 plugin/src/core/procedures/desugar.mli diff --git a/.gitmodules b/.gitmodules index f3da973..e56dc79 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,6 @@ [submodule "plugin/src/coq-plugin-lib"] path = plugin/src/coq-plugin-lib url = https://github.com/uwplse/coq-plugin-lib.git +[submodule "plugin/deps/fix-to-elim"] + path = plugin/deps/fix-to-elim + url = https://github.com/uwplse/fix-to-elim.git diff --git a/plugin/_CoqProject b/plugin/_CoqProject index a79b8c4..647cb83 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -102,8 +102,6 @@ src/core/procedures/search.mli src/core/procedures/search.ml src/core/procedures/theorem.mli src/core/procedures/theorem.ml -src/core/procedures/desugar.mli -src/core/procedures/desugar.ml src/patcher.ml4 src/patch.mlpack diff --git a/plugin/build.sh b/plugin/build.sh index 23d8e49..c2e2a12 100755 --- a/plugin/build.sh +++ b/plugin/build.sh @@ -1,5 +1,10 @@ #!/usr/bin/env bash git submodule init git submodule update +echo "building dependencies" +cd deps/fix-to-elim/plugin +./build.sh +cd ../../.. +echo "building PUMPKIN PATCH" coq_makefile -f _CoqProject -o Makefile make clean && make && make install diff --git a/plugin/coq/Preprocess.v b/plugin/coq/Preprocess.v deleted file mode 100644 index 41cf48a..0000000 --- a/plugin/coq/Preprocess.v +++ /dev/null @@ -1,1871 +0,0 @@ -Require Import Patcher.Patch. -Require List. - -(* - * Test for the Preprocess command to convert - * fixpoints to induction principles. From - * DEVOID, by Nate Yazdani. - *) - -Open Scope list_scope. - -Inductive vector (A : Type) : nat -> Type := -| nilV : vector A 0 -| consV : forall (n : nat), A -> vector A n -> vector A (S n). - -(** Test a few hand-written functions on vector **) -Section VectorTests. - - Arguments nilV {A}. - Arguments consV {A}. - - Definition emptyV (A : Type) (xs : {n:nat & vector A n}) : bool := - match projT2 xs with - | consV _ _ _ => false - | nilV => true - end. - Preprocess emptyV as emptyV'. - - Definition headV (A : Type) (n : nat) (xs : vector A (S n)) : A := - match xs in vector _ n return (match n with S _ => True | O => False end) -> A with - | consV _ x _ => True_rect x - | nilV => False_rect A - end - I. - Preprocess headV as headV'. - - Definition tailV (A : Type) (n : nat) (xs : vector A (S n)) : vector A n := - match xs in vector _ (S n) return vector A n with - | consV _ _ xs => xs - end. - Preprocess tailV as tailV'. - -End VectorTests. - -(** Test a sample of List functions and proofs **) -(* NOTE: Untranslated constants length, app, and List.* remain in many translated terms. *) -Section ListTests. - - Preprocess List.hd as actual_hd. - Definition expected_hd (A : Type) (default : A) (l : list A) : A := - list_rect (fun _ : list A => A) default - (fun (x : A) (_ : list A) (_ : A) => x) l. - Lemma test_hd : actual_hd = expected_hd. Proof. reflexivity. Qed. - - Preprocess List.hd_error as actual_hd_error. - Definition expected_hd_error (A : Type) (l : list A) : option A := - list_rect (fun _ : list A => option A) None - (fun (x : A) (_ : list A) (_ : option A) => Some x) l. - Lemma test_hd_error : actual_hd_error = expected_hd_error. Proof. reflexivity. Qed. - - Preprocess List.tl as actual_tl. - Definition expected_tl (A : Type) (l : list A) : list A := - list_rect (fun _ : list A => list A) nil (fun (_ : A) (m _ : list A) => m) l. - Lemma test_tl : actual_tl = expected_tl. Proof. reflexivity. Qed. - - Preprocess List.In as actual_In. - Definition expected_In (A : Type) (a : A) (l : list A) : Prop := - list_rect (fun _ : list A => A -> Prop) (fun _ : A => False) - (fun (a0 : A) (_ : list A) (In : A -> Prop) (a1 : A) => a0 = a1 \/ In a1) l - a. - Lemma test_In : actual_In = expected_In. Proof. reflexivity. Qed. - - Preprocess List.nil_cons as actual_nil_cons. - Definition expected_nil_cons (A : Type) (x : A) (l : list A) : nil <> (x :: l) := - fun (H : nil = (x :: l)) => - let H0 : False := - eq_ind nil - (fun e : list A => - list_rect (fun _ : list A => Prop) True - (fun (_ : A) (_ : list A) (_ : Prop) => False) e) I - (x :: l) H - in - False_ind False H0. - Lemma test_nil_cons : actual_nil_cons = expected_nil_cons. Proof. reflexivity. Qed. - - Preprocess List.destruct_list as actual_destruct_list. - Definition expected_destruct_list (A : Type) (l : list A) : {x : A & {tl : list A | l = (x :: tl)%list}} + {l = nil} := - list_rect - (fun l0 : list A => - {x : A & {tl : list A | l0 = (x :: tl)}} + {l0 = nil}) - (inright eq_refl) - (fun (a : A) (tail : list A) - (_ : {x : A & {tl : list A | tail = (x :: tl)}} + {tail = nil}) => - inleft - (existT (fun x : A => {tl : list A | (a :: tail) = (x :: tl)}) - a - (exist (fun tl : list A => (a :: tail) = (a :: tl)) tail - eq_refl))) l. - Lemma test_destruct_list : actual_destruct_list = expected_destruct_list. Proof. reflexivity. Qed. - - Preprocess List.hd_error_tl_repr as actual_hd_error_tl_repr. - Definition expected_hd_error_tl_repr (A : Type) (l : list A) : - forall (a : A) (r : list A), - List.hd_error l = Some a /\ List.tl l = r <-> l = (a :: r) - := - list_ind - (fun l0 : list A => - forall (a : A) (r : list A), - List.hd_error l0 = Some a /\ List.tl l0 = r <-> l0 = (a :: r)) - (fun (a : A) (r : list A) => - conj - (fun H : None = Some a /\ nil = r => - and_ind - (fun (H0 : None = Some a) (_ : nil = r) => - let H2 : False := - eq_ind None - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => False) True e) I (Some a) H0 in - False_ind (nil = (a :: r)) H2) H) - (fun H : nil = (a :: r) => - conj - (let H0 : False := - eq_ind nil - (fun e : list A => - list_rect (fun _ : list A => Prop) True - (fun (_ : A) (_ : list A) (_ : Prop) => False) e) I - (a :: r) H in - False_ind (None = Some a) H0) - (let H0 : False := - eq_ind nil - (fun e : list A => - list_rect (fun _ : list A => Prop) True - (fun (_ : A) (_ : list A) (_ : Prop) => False) e) I - (a :: r) H in - False_ind (nil = r) H0))) - (fun (x : A) (xs : list A) - (_ : forall (a : A) (r : list A), - List.hd_error xs = Some a /\ List.tl xs = r <-> xs = (a :: r)) - (a : A) (r : list A) => - conj - (fun H : Some x = Some a /\ xs = r => - and_ind - (fun (H1 : Some x = Some a) (H2 : xs = r) => - let H0 : Some a = Some a -> (x :: xs) = (a :: r) := - eq_ind (Some x) - (fun y : option A => - y = Some a -> (x :: xs) = (a :: r)) - (fun H0 : Some x = Some a => - (fun H3 : Some x = Some a => - let H4 : x = a := - f_equal - (fun e : option A => - option_rect (fun _ : option A => A) - (fun a0 : A => a0) x e) H3 in - (fun H5 : x = a => - let H6 : x = a := H5 in - eq_ind_r (fun a0 : A => (a0 :: xs) = (a :: r)) - (eq_ind_r - (fun xs0 : list A => (a :: xs0) = (a :: r)) - eq_refl H2) H6) H4) H0) (Some a) H1 in - H0 eq_refl) H) - (fun H : (x :: xs) = (a :: r) => - let H0 : (a :: r) = (a :: r) -> Some x = Some a /\ xs = r := - eq_ind (x :: xs) - (fun y : list A => y = (a :: r) -> Some x = Some a /\ xs = r) - (fun H0 : (x :: xs) = (a :: r) => - (fun H1 : (x :: xs) = (a :: r) => - let H2 : xs = r := - f_equal - (fun e : list A => - list_rect (fun _ : list A => list A) xs - (fun (_ : A) (l0 _ : list A) => l0) e) H1 in - (let H3 : x = a := - f_equal - (fun e : list A => - list_rect (fun _ : list A => A) x - (fun (a0 : A) (_ : list A) (_ : A) => a0) e) H1 in - (fun H4 : x = a => - let H5 : x = a := H4 in - eq_ind_r (fun a0 : A => xs = r -> Some a0 = Some a /\ xs = r) - (fun H6 : xs = r => - let H7 : xs = r := H6 in - eq_ind_r (fun l0 : list A => Some a = Some a /\ l0 = r) - (eq_ind_r - (fun x0 : A => - (x0 :: xs) = (a :: r) -> - Some a = Some a /\ r = r) - (fun H8 : (a :: xs) = (a :: r) => - eq_ind_r - (fun xs0 : list A => - (a :: xs0) = (a :: r) -> - Some a = Some a /\ r = r) - (fun _ : (a :: r) = (a :: r) => - conj eq_refl eq_refl) H6 H8) H4 H) H7) H5) H3) H2) - H0) (a :: r) H in - H0 eq_refl)) l. - Lemma test_hd_error_tl_repr : actual_hd_error_tl_repr = expected_hd_error_tl_repr. Proof. reflexivity. Qed. - - Preprocess List.length_zero_iff_nil as actual_length_zero_iff_nil. - Definition expected_length_zero_iff_nil (A : Type) (l : list A) : (length l = 0 -> l = nil) /\ (l = nil -> length l = 0) := - conj - (list_ind (fun l0 : list A => length l0 = 0 -> l0 = nil) - (fun _ : length nil = 0 => eq_refl) - (fun (a : A) (l0 : list A) (_ : length l0 = 0 -> l0 = nil) - (H : length (a :: l0) = 0) => - let H0 : 0 = 0 -> (a :: l0) = nil := - eq_ind (length (a :: l0)) - (fun y : nat => y = 0 -> (a :: l0) = nil) - (fun H0 : length (a :: l0) = 0 => - (fun H1 : length (a :: l0) = 0 => - let H2 : False := - eq_ind (length (a :: l0)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind ((a :: l0) = nil) H2) H0) 0 H in - H0 eq_refl) l) - (fun H : l = nil => eq_ind_r (fun l0 : list A => length l0 = 0) (@eq_refl nat (length nil)) H). - Lemma test_length_zero_iff_nil : actual_length_zero_iff_nil = expected_length_zero_iff_nil. Proof. reflexivity. Qed. - - Preprocess List.hd_error_nil as actual_hd_error_nil. - Definition expected_hd_error_nil (A : Type) : List.hd_error (@nil A) = None := - eq_refl. - Lemma test_hd_error_nil : actual_hd_error_nil = expected_hd_error_nil. Proof. reflexivity. Qed. - - Preprocess List.hd_error_cons as actual_hd_error_cons. - Definition expected_hd_error_cons (A : Type) (l : list A) (x : A) : List.hd_error (x :: l) = Some x := - eq_refl. - Lemma test_hd_error_cons : actual_hd_error_cons = expected_hd_error_cons. Proof. reflexivity. Qed. - - Preprocess List.in_eq as actual_in_eq. - Definition expected_in_eq (A : Type) (a : A) (l : list A) : List.In a (a :: l) := - or_introl eq_refl. - Lemma test_in_eq : actual_in_eq = expected_in_eq. Proof. reflexivity. Qed. - - Preprocess List.in_cons as actual_in_cons. - Definition expected_in_cons (A : Type) (a b : A) (l : list A) (H : List.In b l) : List.In b (a :: l) := - or_intror H. - Lemma test_in_cons : actual_in_cons = expected_in_cons. Proof. reflexivity. Qed. - - Preprocess List.not_in_cons as actual_not_in_cons. - Definition expected_not_in_cons (A : Type) (x a : A) (l : list A) : ~ List.In x (a :: l) <-> x <> a /\ ~ List.In x l := - conj - (fun H : ~ (a = x \/ List.In x l) => - let H0 : a = x -> False := fun H0 : a = x => H (or_introl H0) in - let H1 : List.In x l -> False := fun H1 : List.In x l => H (or_intror H1) - in - conj (fun H2 : x = a => H0 (eq_sym H2)) - (fun H2 : List.In x l => let H3 : False := H1 H2 in False_ind False H3)) - (fun (H : x <> a /\ ~ List.In x l) (H0 : a = x \/ List.In x l) => - and_ind - (fun (H1 : x <> a) (H2 : ~ List.In x l) => - or_ind (fun H3 : a = x => H1 (eq_sym H3)) - (fun H3 : List.In x l => - let H4 : False := H2 H3 in False_ind False H4) H0) H). - Lemma test_not_in_cons : actual_not_in_cons = expected_not_in_cons. Proof. reflexivity. Qed. - - Preprocess List.in_nil as actual_in_nil. - Definition expected_in_nil (A : Type) (a : A) : ~ List.In a nil := - fun (H : List.In a nil) => - let H0 : False := False_ind False H in H0. - Lemma test_in_nil : actual_in_nil = expected_in_nil. Proof. reflexivity. Qed. - - Preprocess List.in_split as actual_in_split. - Definition expected_in_split (A : Type) (x : A) (l : list A) : List.In x l -> exists l1 l2 : list A, l = (l1 ++ x :: l2) := - list_ind - (fun l0 : list A => - List.In x l0 -> exists l1 l2 : list A, l0 = (l1 ++ x :: l2)) - (fun H : False => - False_ind (exists l1 l2 : list A, nil = (l1 ++ x :: l2)) H) - (fun (a : A) (l0 : list A) - (IHl : List.In x l0 -> exists l1 l2 : list A, l0 = (l1 ++ x :: l2)) - (H : a = x \/ List.In x l0) => - or_ind - (fun H0 : a = x => - eq_ind_r - (fun a0 : A => - exists l1 l2 : list A, (a0 :: l0) = (l1 ++ x :: l2)) - (ex_intro - (fun l1 : list A => - exists l2 : list A, (x :: l0) = (l1 ++ x :: l2)) nil - (ex_intro - (fun l2 : list A => (x :: l0) = (nil ++ x :: l2)) l0 - eq_refl)) H0) - (fun H0 : List.In x l0 => - let e : exists l1 l2 : list A, l0 = (l1 ++ x :: l2) := IHl H0 in - ex_ind - (fun (l1 : list A) - (H1 : exists l2 : list A, l0 = (l1 ++ x :: l2)) => - ex_ind - (fun (l2 : list A) (H2 : l0 = (l1 ++ x :: l2)) => - ex_intro - (fun l3 : list A => - exists l4 : list A, (a :: l0) = (l3 ++ x :: l4)) - (a :: l1) - (ex_intro - (fun l3 : list A => - (a :: l0) = ((a :: l1) ++ x :: l3)) l2 - (f_equal (cons a) H2))) H1) e) H) l. - Lemma test_in_split : actual_in_split = expected_in_split. Proof. reflexivity. Qed. - - Preprocess List.in_dec as actual_in_dec. - Definition expected_in_dec (A : Type) (H : forall x y : A, {x = y} + {x <> y}) (a : A) (l : list A) : {List.In a l} + {~ List.In a l} := - list_rec (fun l0 : list A => {List.In a l0} + {~ List.In a l0}) - (right (List.in_nil (a:=a))) - (fun (a0 : A) (l0 : list A) (IHl : {List.In a l0} + {~ List.In a l0}) => - let s := H a0 a in - sumbool_rec - (fun _ : {a0 = a} + {a0 <> a} => - {List.In a (a0 :: l0)} + {~ List.In a (a0 :: l0)}) - (fun e : a0 = a => left (or_introl e)) - (fun n : a0 <> a => - sumbool_rec - (fun _ : {List.In a l0} + {~ List.In a l0} => - {a0 = a \/ List.In a l0} + {~ (a0 = a \/ List.In a l0)}) - (fun i : List.In a l0 => left (or_intror i)) - (fun n0 : ~ List.In a l0 => - right - (fun H0 : a0 = a \/ List.In a l0 => - or_ind (fun Hc1 : a0 = a => n Hc1) - (fun Hc2 : List.In a l0 => n0 Hc2) H0)) IHl) s) l. - Lemma test_in_dec : actual_in_dec = expected_in_dec. Proof. reflexivity. Qed. - - Preprocess List.app_cons_not_nil as actual_app_cons_not_nil. - Definition expected_app_cons_not_nil (A : Type) (x : list A) : forall (y : list A) (a : A), nil <> (x ++ a :: y) := - list_ind - (fun l : list A => - forall (y : list A) (a : A), nil = (l ++ a :: y) -> False) - (fun (y : list A) (a : A) (H : nil = (a :: y)) => - let H0 : False := - eq_ind nil - (fun e : list A => - list_rect (fun _ : list A => Prop) True - (fun (_ : A) (_ : list A) (_ : Prop) => False) e) I - (a :: y) H in - False_ind False H0) - (fun (a : A) (l : list A) - (_ : forall (y : list A) (a0 : A), nil = (l ++ a0 :: y) -> False) - (y : list A) (a0 : A) (H : nil = (a :: l ++ a0 :: y)) => - let H0 : False := - eq_ind nil - (fun e : list A => - list_rect (fun _ : list A => Prop) True - (fun (_ : A) (_ : list A) (_ : Prop) => False) e) I - (a :: l ++ a0 :: y) H in - False_ind False H0) x. - Lemma test_app_cons_not_nil : actual_app_cons_not_nil = expected_app_cons_not_nil. Proof. reflexivity. Qed. - - Preprocess List.app_nil_l as actual_app_nil_l. - Definition expected_app_nil_l (A : Type) (l : list A) : nil ++ l = l := - eq_refl. - Lemma test_app_nil_l : actual_app_nil_l = expected_app_nil_l. Proof. reflexivity. Qed. - - Preprocess List.app_nil_r as actual_app_nil_r. - Definition expected_app_nil_r (A : Type) (l : list A) : (l ++ nil) = l := - list_ind (fun l0 : list A => (l0 ++ nil) = l0) - (let H : A = A := eq_refl in (fun _ : A = A => eq_refl) H) - (fun (a : A) (l0 : list A) (IHl : (l0 ++ nil) = l0) => - let H : (l0 ++ nil) = l0 := IHl in - (let H0 : a = a := eq_refl in - (let H1 : A = A := eq_refl in - (fun (_ : A = A) (_ : a = a) (H4 : (l0 ++ nil) = l0) => - eq_trans - (f_equal (fun f : list A -> list A => f (l0 ++ nil)) eq_refl) - (f_equal (cons a) H4)) H1) H0) H) l. - Lemma test_app_nil_r : actual_app_nil_r = expected_app_nil_r. Proof. reflexivity. Qed. - - Preprocess List.app_nil_end as actual_app_nil_end. - Definition expected_app_nil_end (A : Type) (l : list A) : l = l ++ nil := - eq_sym (List.app_nil_r l). - Lemma test_app_nil_end : actual_app_nil_end = expected_app_nil_end. Proof. reflexivity. Qed. - - Preprocess List.app_assoc as actual_app_assoc. - Definition expected_app_assoc (A : Type) (l m n : list A) : l ++ m ++ n = (l ++ m) ++ n := - list_ind (fun l0 : list A => (l0 ++ m ++ n) = ((l0 ++ m) ++ n)) - (let H : n = n := eq_refl in - (let H0 : m = m := eq_refl in - (let H1 : A = A := eq_refl in - (fun (_ : A = A) (_ : m = m) (_ : n = n) => eq_refl) H1) H0) H) - (fun (a : A) (l0 : list A) - (IHl : (l0 ++ m ++ n) = ((l0 ++ m) ++ n)) => - let H : (l0 ++ m ++ n) = ((l0 ++ m) ++ n) := IHl in - (let H0 : a = a := eq_refl in - (let H1 : A = A := eq_refl in - (fun (_ : A = A) (_ : a = a) - (H4 : (l0 ++ m ++ n) = ((l0 ++ m) ++ n)) => - eq_trans - (f_equal (fun f : list A -> list A => f (l0 ++ m ++ n)) eq_refl) - (f_equal (cons a) H4)) H1) H0) H) l. - Lemma test_app_assoc : actual_app_assoc = expected_app_assoc. Proof. reflexivity. Qed. - - Preprocess List.app_assoc_reverse as actual_app_assoc_reverse. - Definition expected_app_assoc_reverse (A : Type) (l m n : list A) : ((l ++ m) ++ n) = (l ++ m ++ n) := - eq_sym (List.app_assoc l m n). - Lemma test_app_assoc_reverse : actual_app_assoc_reverse = expected_app_assoc_reverse. Proof. reflexivity. Qed. - - Preprocess List.app_comm_cons as actual_app_comm_cons. - Definition expected_app_comm_cons (A : Type) (x y : list A) (a : A) : a :: x ++ y = (a :: x) ++ y := - eq_refl. - Lemma test_app_comm_cons : actual_app_comm_cons = expected_app_comm_cons. Proof. reflexivity. Qed. - - Preprocess List.app_eq_nil as actual_app_eq_nil. - Definition expected_app_eq_nil (A : Type) (l : list A) : forall (l' : list A), l ++ l' = nil -> l = nil /\ l' = nil := - list_ind - (fun l0 : list A => - forall l' : list A, (l0 ++ l') = nil -> l0 = nil /\ l' = nil) - (fun l' : list A => - list_ind - (fun l0 : list A => (nil ++ l0) = nil -> nil = nil /\ l0 = nil) - (fun H : nil = nil => conj H H) - (fun (y : A) (l'0 : list A) - (_ : (nil ++ l'0) = nil -> nil = nil /\ l'0 = nil) - (H : (y :: l'0) = nil) => conj eq_refl H) l') - (fun (x : A) (l0 : list A) - (_ : forall l' : list A, (l0 ++ l') = nil -> l0 = nil /\ l' = nil) - (l' : list A) => - list_ind - (fun l1 : list A => - ((x :: l0) ++ l1) = nil -> (x :: l0) = nil /\ l1 = nil) - (fun H : (x :: l0 ++ nil) = nil => - let H0 : False := - eq_ind (x :: l0 ++ nil) - (fun e : list A => - list_rect (fun _ : list A => Prop) False - (fun (_ : A) (_ : list A) (_ : Prop) => True) e) I nil H in - False_ind ((x :: l0) = nil /\ nil = nil) H0) - (fun (y : A) (l'0 : list A) - (_ : ((x :: l0) ++ l'0) = nil -> - (x :: l0) = nil /\ l'0 = nil) - (H : (x :: l0 ++ y :: l'0) = nil) => - let H0 : False := - eq_ind (x :: l0 ++ y :: l'0) - (fun e : list A => - list_rect (fun _ : list A => Prop) False - (fun (_ : A) (_ : list A) (_ : Prop) => True) e) I nil H in - False_ind ((x :: l0) = nil /\ (y :: l'0) = nil) H0) l') l. - Lemma test_app_eq_nil : actual_app_eq_nil = expected_app_eq_nil. Proof. reflexivity. Qed. - - Preprocess List.app_eq_unit as actual_app_eq_unit. - Definition expected_app_eq_unit (A : Type) (x : list A) : - forall (y : list A) (a : A), - x ++ y = a :: nil -> x = nil /\ y = a :: nil \/ x = a :: nil /\ y = nil - := - list_ind - (fun l : list A => - forall (y : list A) (a : A), - (l ++ y) = (a :: nil) -> - l = nil /\ y = (a :: nil) \/ l = (a :: nil) /\ y = nil) - (fun y : list A => - list_ind - (fun l : list A => - forall a : A, - (nil ++ l) = (a :: nil) -> - nil = nil /\ l = (a :: nil) \/ nil = (a :: nil) /\ l = nil) - (fun (a : A) (H : nil = (a :: nil)) => - let H0 : False := - eq_ind nil - (fun e : list A => - list_rect (fun _ : list A => Prop) True - (fun (_ : A) (_ : list A) (_ : Prop) => False) e) I - (a :: nil) H in - False_ind - (nil = nil /\ nil = (a :: nil) \/ - nil = (a :: nil) /\ nil = nil) H0) - (fun (a : A) (l : list A) - (_ : forall a0 : A, - (nil ++ l) = (a0 :: nil) -> - nil = nil /\ l = (a0 :: nil) \/ - nil = (a0 :: nil) /\ l = nil) (a0 : A) - (H : (a :: l) = (a0 :: nil)) => - or_introl (conj eq_refl H)) y) - (fun (a : A) (l : list A) - (_ : forall (y : list A) (a0 : A), - (l ++ y) = (a0 :: nil) -> - l = nil /\ y = (a0 :: nil) \/ l = (a0 :: nil) /\ y = nil) - (y : list A) => - list_ind - (fun l0 : list A => - forall a0 : A, - ((a :: l) ++ l0) = (a0 :: nil) -> - (a :: l) = nil /\ l0 = (a0 :: nil) \/ - (a :: l) = (a0 :: nil) /\ l0 = nil) - (fun (a0 : A) (H : (a :: l ++ nil) = (a0 :: nil)) => - or_intror - (conj - ((fun E : (l ++ nil) = l => - eq_ind_r - (fun l0 : list A => - (a :: l0) = (a0 :: nil) -> - (a :: l) = (a0 :: nil)) - (fun H0 : (a :: l) = (a0 :: nil) => H0) E) - (List.app_nil_r l) H) eq_refl)) - (fun (a0 : A) (l0 : list A) - (_ : forall a1 : A, - ((a :: l) ++ l0) = (a1 :: nil) -> - (a :: l) = nil /\ l0 = (a1 :: nil) \/ - (a :: l) = (a1 :: nil) /\ l0 = nil) - (a1 : A) (H : (a :: l ++ a0 :: l0) = (a1 :: nil)) => - let H0 : (l ++ a0 :: l0) = nil := - f_equal - (fun e : list A => - list_rect (fun _ : list A => list A) - ((fun l1 : list A => - list_rect (fun _ : list A => list A -> list A) - (fun m : list A => m) - (fun (a2 : A) (_ : list A) (app : list A -> list A) - (m : list A) => (a2 :: app m)) l1) l - (a0 :: l0)) (fun (_ : A) (l1 _ : list A) => l1) e) H in - (let H1 : a = a1 := - f_equal - (fun e : list A => - list_rect (fun _ : list A => A) a - (fun (a2 : A) (_ : list A) (_ : A) => a2) e) H in - (fun (_ : a = a1) (H3 : (l ++ a0 :: l0) = nil) => - let H4 : nil = (l ++ a0 :: l0) := eq_sym H3 in - let H5 : False := List.app_cons_not_nil l l0 a0 H4 in - False_ind - ((a :: l) = nil /\ (a0 :: l0) = (a1 :: nil) \/ - (a :: l) = (a1 :: nil) /\ (a0 :: l0) = nil) H5) H1) - H0) y) x. - Lemma test_app_eq_unit : actual_app_eq_unit = expected_app_eq_unit. Proof. reflexivity. Qed. - - Preprocess List.app_length as actual_app_length. - Definition expected_app_length (A : Type) (l : list A) : forall (l' : list A), length (l ++ l') = length l + length l' := - list_ind - (fun l0 : list A => - forall l' : list A, length (l0 ++ l') = length l0 + length l') - (fun l' : list A => eq_refl) - (fun (a : A) (l0 : list A) - (IHl : forall l' : list A, length (l0 ++ l') = length l0 + length l') - (l' : list A) => - f_equal_nat nat S (length (l0 ++ l')) (length l0 + length l') (IHl l')) l. - Lemma test_app_length : actual_app_length = expected_app_length. Proof. reflexivity. Qed. - - Preprocess List.in_app_or as actual_in_app_or. - Definition expected_in_app_or (A : Type) (l m : list A) (a : A) : List.In a (l ++ m) -> List.In a l \/ List.In a m := - list_ind - (fun l0 : list A => List.In a (l0 ++ m) -> List.In a l0 \/ List.In a m) - (fun H : List.In a m => or_intror H) - (fun (a0 : A) (y : list A) - (H : List.In a (y ++ m) -> List.In a y \/ List.In a m) - (H0 : a0 = a \/ List.In a (y ++ m)) => - or_ind (fun H1 : a0 = a => or_introl (or_introl H1)) - (fun H1 : List.In a (y ++ m) => - or_ind (fun H2 : List.In a y => or_introl (or_intror H2)) - (fun H2 : List.In a m => or_intror H2) (H H1)) H0) l. - Lemma test_in_app_or : actual_in_app_or = expected_in_app_or. Proof. reflexivity. Qed. - - Preprocess List.in_or_app as actual_in_or_app. - Definition expected_in_or_app (A : Type) (l m : list A) (a : A) : List.In a l \/ List.In a m -> List.In a (l ++ m) := - list_ind - (fun l0 : list A => List.In a l0 \/ List.In a m -> List.In a (l0 ++ m)) - (fun H : False \/ List.In a m => - or_ind (fun H0 : False => False_ind (List.In a m) H0) - (fun H0 : List.In a m => H0) H) - (fun (H : A) (y : list A) - (H0 : List.In a y \/ List.In a m -> List.In a (y ++ m)) - (H1 : (H = a \/ List.In a y) \/ List.In a m) => - or_ind - (fun H2 : H = a \/ List.In a y => - or_ind (fun H3 : H = a => or_introl H3) - (fun H3 : List.In a y => or_intror (H0 (or_introl H3))) H2) - (fun H2 : List.In a m => or_intror (H0 (or_intror H2))) H1) l. - Lemma test_in_or_app : actual_in_or_app = expected_in_or_app. Proof. reflexivity. Qed. - - Preprocess List.in_app_iff as actual_in_app_iff. - Definition expected_in_app_iff (A : Type) (l l' : list A) (a : A) : List.In a (l ++ l') <-> List.In a l \/ List.In a l' := - conj (fun H : List.In a (l ++ l') => List.in_app_or l l' a H) - (fun H : List.In a l \/ List.In a l' => List.in_or_app l l' a H). - Lemma test_in_app_iff : actual_in_app_iff = expected_in_app_iff. Proof. reflexivity. Qed. - - Preprocess List.app_inv_head as actual_app_inv_head. - Definition expected_app_inv_head (A : Type) (l : list A) : forall (l1 l2 : list A), (l ++ l1) = (l ++ l2) -> l1 = l2 := - list_ind - (fun l0 : list A => - forall l1 l2 : list A, (l0 ++ l1) = (l0 ++ l2) -> l1 = l2) - (fun (l1 l2 : list A) (H : l1 = l2) => H) - (fun (a : A) (l0 : list A) - (IHl : forall l1 l2 : list A, - (l0 ++ l1) = (l0 ++ l2) -> l1 = l2) - (l1 l2 : list A) (H : (a :: l0 ++ l1) = (a :: l0 ++ l2)) => - let H0 : (l0 ++ l1) = (l0 ++ l2) := - f_equal - (fun e : list A => - list_rect (fun _ : list A => list A) - ((fun l3 : list A => - list_rect (fun _ : list A => list A -> list A) - (fun m : list A => m) - (fun (a0 : A) (_ : list A) (app : list A -> list A) - (m : list A) => (a0 :: app m)) l3) l0 l1) - (fun (_ : A) (l3 _ : list A) => l3) e) H in - (fun H1 : (l0 ++ l1) = (l0 ++ l2) => IHl l1 l2 H1) H0) l. - Lemma test_app_inv_head : actual_app_inv_head = expected_app_inv_head. Proof. reflexivity. Qed. - - Preprocess List.app_inv_tail as actual_app_inv_tail. - Definition expected_app_inv_tail (A : Type) (l l1 l2 : list A) : (l1 ++ l) = (l2 ++ l) -> l1 = l2 := - (fun l3 : list A => - list_ind - (fun l4 : list A => - forall l5 l0 : list A, (l4 ++ l0) = (l5 ++ l0) -> l4 = l5) - (fun l4 : list A => - list_ind - (fun l0 : list A => - forall l5 : list A, (nil ++ l5) = (l0 ++ l5) -> nil = l0) - (fun (l0 : list A) (_ : l0 = l0) => eq_refl) - (fun (x2 : A) (l5 : list A) - (_ : forall l0 : list A, - (nil ++ l0) = (l5 ++ l0) -> nil = l5) - (l0 : list A) (H : l0 = (x2 :: l5 ++ l0)) => - False_ind (nil = (x2 :: l5)) - (eq_ind_r (fun n : nat => ~ S n <= length l0) - (Gt.gt_not_le (S (length l5 + length l0)) - (length l0) - (Le.le_n_S (length l0) (length l5 + length l0) - (Plus.le_plus_r (length l5) (length l0)))) - (List.app_length l5 l0) - (eq_ind l0 (fun l6 : list A => length l6 <= length l0) - (le_n (length l0)) (x2 :: l5 ++ l0) H))) l4) - (fun (x1 : A) (l4 : list A) - (IHl1 : forall l5 l0 : list A, - (l4 ++ l0) = (l5 ++ l0) -> l4 = l5) - (l5 : list A) => - list_ind - (fun l0 : list A => - forall l6 : list A, - ((x1 :: l4) ++ l6) = (l0 ++ l6) -> (x1 :: l4) = l0) - (fun (l0 : list A) (H : (x1 :: l4 ++ l0) = l0) => - False_ind ((x1 :: l4) = nil) - (eq_ind_r (fun n : nat => ~ S n <= length l0) - (Gt.gt_not_le (S (length l4 + length l0)) - (length l0) - (Le.le_n_S (length l0) (length l4 + length l0) - (Plus.le_plus_r (length l4) (length l0)))) - (List.app_length l4 l0) - (eq_ind_r (fun l6 : list A => length l6 <= length l0) - (le_n (length l0)) H))) - (fun (x2 : A) (l6 : list A) - (_ : forall l0 : list A, - ((x1 :: l4) ++ l0) = (l6 ++ l0) -> - (x1 :: l4) = l6) (l0 : list A) - (H : (x1 :: l4 ++ l0) = (x2 :: l6 ++ l0)) => - let H0 : (l4 ++ l0) = (l6 ++ l0) := - f_equal - (fun e : list A => - list_rect (fun _ : list A => list A) - ((fun l7 : list A => - list_rect (fun _ : list A => list A -> list A) - (fun m : list A => m) - (fun (l8 : A) (_ : list A) (app : list A -> list A) - (m : list A) => (l8 :: app m)) l7) l4 l0) - (fun (_ : A) (l7 _ : list A) => l7) e) H in - (let H1 : x1 = x2 := - f_equal - (fun e : list A => - list_rect (fun _ : list A => A) x1 - (fun (a : A) (_ : list A) (_ : A) => a) e) H in - (fun (H2 : x1 = x2) (H3 : (l4 ++ l0) = (l6 ++ l0)) => - let H4 : l4 = l6 := IHl1 l6 l0 H3 in - (let H5 : x1 = x2 := H2 in - (let H6 : A = A := eq_refl in - (fun (_ : A = A) (H8 : x1 = x2) (H9 : l4 = l6) => - eq_trans - (f_equal (fun f : list A -> list A => f l4) - (eq_trans - (f_equal (fun f : A -> list A -> list A => f x1) eq_refl) - (f_equal cons H8))) (f_equal (cons x2) H9)) H6) H5) H4) - H1) H0) l5) l3) l1 l2 l. - Lemma test_app_inv_tail : actual_app_inv_tail = expected_app_inv_tail. Proof. reflexivity. Qed. - - Preprocess List.nth as actual_nth. - Definition expected_nth (A : Type) (n : nat) (l : list A) : A -> A := - list_rect (fun _ : list A => nat -> A -> A) - (fun (n0 : nat) (default : A) => - nat_rect (fun _ : nat => A) default (fun (_ : nat) (_ : A) => default) n0) - (fun (a : A) (_ : list A) (nth : nat -> A -> A) (n0 : nat) (default : A) => - nat_rect (fun _ : nat => A) a (fun (m : nat) (_ : A) => nth m default) n0) - l n. - Lemma test_actual_nth : actual_nth = expected_nth. Proof. reflexivity. Qed. - - Preprocess List.nth_ok as actual_nth_ok. - Definition expected_nth_ok (A : Type) (n : nat) (l : list A) : A -> bool := - list_rect (fun _ : list A => nat -> A -> bool) - (fun (n0 : nat) (_ : A) => - nat_rec (fun _ : nat => bool) false (fun (_ : nat) (_ : bool) => false) n0) - (fun (_ : A) (_ : list A) (nth_ok : nat -> A -> bool) - (n0 : nat) (default : A) => - nat_rec (fun _ : nat => bool) true - (fun (m : nat) (_ : bool) => nth_ok m default) n0) l n. - Lemma test_nth_ok : actual_nth_ok = expected_nth_ok. Proof. reflexivity. Qed. - - Preprocess List.nth_in_or_default as actual_nth_in_or_default. - Definition expected_nth_in_or_default (A : Type) (n : nat) (l : list A) (d : A) : {List.In (List.nth n l d) l} + {List.nth n l d = d} := - list_rec - (fun l0 : list A => - forall n0 : nat, {List.In (List.nth n0 l0 d) l0} + {List.nth n0 l0 d = d}) - (fun n0 : nat => - right - (nat_ind (fun n1 : nat => List.nth n1 nil d = d) eq_refl - (fun (n1 : nat) (_ : List.nth n1 nil d = d) => eq_refl) n0)) - (fun (a : A) (l0 : list A) - (IHl : forall n0 : nat, - {List.In (List.nth n0 l0 d) l0} + {List.nth n0 l0 d = d}) - (n0 : nat) => - nat_rec - (fun n1 : nat => - {List.In (List.nth n1 (a :: l0) d) (a :: l0)} + - {List.nth n1 (a :: l0) d = d}) (left (or_introl eq_refl)) - (fun (n1 : nat) - (_ : {List.In (List.nth n1 (a :: l0) d) (a :: l0)} + - {List.nth n1 (a :: l0) d = d}) => - let s := IHl n1 in - sumbool_rec - (fun _ : {List.In (List.nth n1 l0 d) l0} + {List.nth n1 l0 d = d} => - {a = List.nth n1 l0 d \/ List.In (List.nth n1 l0 d) l0} + - {List.nth n1 l0 d = d}) - (fun i : List.In (List.nth n1 l0 d) l0 => left (or_intror i)) - (fun e : List.nth n1 l0 d = d => right e) s) n0) l n. - Lemma test_nth_in_or_default : actual_nth_in_or_default = expected_nth_in_or_default. Proof. reflexivity. Qed. - - Preprocess List.nth_S_cons as actual_nth_S_cons. - Definition expected_nth_S_cons (A : Type) (n : nat) (l : list A) (d a : A) (H : List.In (List.nth n l d) l) : - List.In (List.nth (S n) (a :: l) d) (a :: l) - := - or_intror H. - Lemma test_nth_S_cons : actual_nth_S_cons = expected_nth_S_cons. Proof. reflexivity. Qed. - - Preprocess List.nth_error as actual_nth_error. - Definition expected_nth_error (A : Type) (l : list A) (n : nat) : option A := - nat_rect (fun _ : nat => list A -> option A) - (fun l0 : list A => - list_rect (fun _ : list A => option A) None - (fun (x : A) (_ : list A) (_ : option A) => Some x) l0) - (fun (_ : nat) (nth_error : list A -> option A) (l0 : list A) => - list_rect (fun _ : list A => option A) None - (fun (_ : A) (l1 : list A) (_ : option A) => nth_error l1) l0) n l. - Lemma test_nth_error : actual_nth_error = expected_nth_error. Proof. reflexivity. Qed. - - Preprocess List.nth_default as actual_nth_default. - Definition expected_nth_default (A : Type) (default : A) (l : list A) (n : nat) : A := - option_rect (fun _ : option A => A) (fun x : A => x) default (List.nth_error l n). - Lemma test_nth_default : actual_nth_default = expected_nth_default. Proof. reflexivity. Qed. - - Preprocess List.nth_default_eq as actual_nth_default_eq. - Definition expected_nth_default_eq (A : Type) (n : nat) : - forall (l : list A) (d : A), List.nth_default d l n = List.nth n l d - := - nat_ind - (fun n0 : nat => - forall (l : list A) (d : A), - option_rect (fun _ : option A => A) (fun x : A => x) d - (List.nth_error l n0) = List.nth n0 l d) - (fun l : list A => - list_ind - (fun l0 : list A => - forall d : A, - option_rect (fun _ : option A => A) (fun x : A => x) d - (List.nth_error l0 0) = List.nth 0 l0 d) (fun d : A => eq_refl) - (fun (a : A) (l0 : list A) - (_ : forall d : A, - option_rect (fun _ : option A => A) (fun x : A => x) d - (List.nth_error l0 0) = List.nth 0 l0 d) - (d : A) => eq_refl) l) - (fun (n0 : nat) - (IHn : forall (l : list A) (d : A), - option_rect (fun _ : option A => A) (fun x : A => x) d - (List.nth_error l n0) = List.nth n0 l d) - (l : list A) => - list_ind - (fun l0 : list A => - forall d : A, - option_rect (fun _ : option A => A) (fun x : A => x) d - (List.nth_error l0 (S n0)) = List.nth (S n0) l0 d) - (fun d : A => eq_refl) - (fun (a : A) (l0 : list A) - (_ : forall d : A, - option_rect (fun _ : option A => A) (fun x : A => x) d - (List.nth_error l0 (S n0)) = List.nth (S n0) l0 d) - (d : A) => IHn l0 d) l) n. - Lemma test_nth_default_eq : actual_nth_default_eq = expected_nth_default_eq. Proof. reflexivity. Qed. - - Preprocess List.nth_overflow as actual_nth_overflow. - Definition expected_nth_overflow (A : Type) (l : list A) : - forall (n : nat) (d : A), length l <= n -> List.nth n l d = d - := - list_ind - (fun l0 : list A => - forall (n : nat) (d : A), length l0 <= n -> List.nth n l0 d = d) - (fun n : nat => - nat_ind - (fun n0 : nat => forall d : A, length nil <= n0 -> List.nth n0 nil d = d) - (fun (d : A) (_ : 0 <= 0) => eq_refl) - (fun (n0 : nat) - (_ : forall d : A, length nil <= n0 -> List.nth n0 nil d = d) - (d : A) (_ : 0 <= S n0) => eq_refl) n) - (fun (a : A) (l0 : list A) - (IHl : forall (n : nat) (d : A), length l0 <= n -> List.nth n l0 d = d) - (n : nat) => - nat_ind - (fun n0 : nat => - forall d : A, length (a :: l0) <= n0 -> List.nth n0 (a :: l0) d = d) - (fun (d : A) (H : S (length l0) <= 0) => - let H0 : 0 = 0 -> a = d := - le_ind (S (length l0)) (fun n0 : nat => n0 = 0 -> a = d) - (fun H0 : S (length l0) = 0 => - (fun H1 : S (length l0) = 0 => - let H2 : False := - eq_ind (S (length l0)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind (a = d) H2) H0) - (fun (m : nat) (H0 : S (length l0) <= m) - (_ : m = 0 -> a = d) (H1 : S m = 0) => - (fun H2 : S m = 0 => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H2 in - False_ind (S (length l0) <= m -> a = d) H3) H1 H0) 0 H in - H0 eq_refl) - (fun (n0 : nat) - (_ : forall d : A, - length (a :: l0) <= n0 -> List.nth n0 (a :: l0) d = d) - (d : A) (H : S (length l0) <= S n0) => - IHl n0 d (Gt.gt_S_le (length l0) n0 H)) n) l. - Lemma test_nth_overflow : actual_nth_overflow = expected_nth_overflow. Proof. reflexivity. Qed. - - Preprocess List.nth_indep as actual_nth_indep. - Definition expected_nth_indep (A : Type) (l : list A) : - forall (n : nat) (d d' : A), n < length l -> List.nth n l d = List.nth n l d' - := - list_ind - (fun l0 : list A => - forall (n : nat) (d d' : A), - n < length l0 -> List.nth n l0 d = List.nth n l0 d') - (fun (n : nat) (d d' : A) (H : n < length nil) => - let H0 : - length nil = length nil -> List.nth n nil d = List.nth n nil d' := - le_ind (S n) - (fun n0 : nat => - n0 = length nil -> List.nth n nil d = List.nth n nil d') - (fun H0 : S n = length nil => - (fun H1 : S n = length nil => - let H2 : False := - eq_ind (S n) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H1 in - False_ind (List.nth n nil d = List.nth n nil d') H2) H0) - (fun (m : nat) (H0 : S n <= m) - (_ : m = length nil -> List.nth n nil d = List.nth n nil d') - (H1 : S m = length nil) => - (fun H2 : S m = length nil => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H2 in - False_ind (S n <= m -> List.nth n nil d = List.nth n nil d') H3) H1 - H0) (length nil) H in - H0 eq_refl) - (fun (a : A) (l0 : list A) - (IHl : forall (n : nat) (d d' : A), - n < length l0 -> List.nth n l0 d = List.nth n l0 d') - (n0 : nat) => - nat_ind - (fun n : nat => - forall d d' : A, - n < length (a :: l0) -> - List.nth n (a :: l0) d = List.nth n (a :: l0) d') - (fun (d d' : A) (_ : 0 < S (length l0)) => eq_refl) - (fun (n : nat) - (_ : forall d d' : A, - n < length (a :: l0) -> - List.nth n (a :: l0) d = List.nth n (a :: l0) d') - (d d' : A) (H : S n < S (length l0)) => - IHl n d d' (Gt.gt_le_S n (length l0) (Lt.lt_S_n n (length l0) H))) n0) - l. - Lemma test_nth_indep : actual_nth_indep = expected_nth_indep. Proof. reflexivity. Qed. - - Preprocess List.app_nth1 as actual_app_nth1. - Definition expected_app_nth1 (A : Type) (l : list A) : - forall (l' : list A) (d : A) (n : nat), - n < length l -> List.nth n (l ++ l') d = List.nth n l d - := - list_ind - (fun l0 : list A => - forall (l' : list A) (d : A) (n : nat), - n < length l0 -> List.nth n (l0 ++ l') d = List.nth n l0 d) - (fun (l' : list A) (d : A) (n : nat) (H : n < length nil) => - let H0 : - length nil = length nil -> List.nth n (nil ++ l') d = List.nth n nil d := - le_ind (S n) - (fun n0 : nat => - n0 = length nil -> List.nth n (nil ++ l') d = List.nth n nil d) - (fun H0 : S n = length nil => - (fun H1 : S n = length nil => - let H2 : False := - eq_ind (S n) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H1 in - False_ind (List.nth n (nil ++ l') d = List.nth n nil d) H2) H0) - (fun (m : nat) (H0 : S n <= m) - (_ : m = length nil -> List.nth n (nil ++ l') d = List.nth n nil d) - (H1 : S m = length nil) => - (fun H2 : S m = length nil => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H2 in - False_ind (S n <= m -> List.nth n (nil ++ l') d = List.nth n nil d) - H3) H1 H0) (length nil) H in - H0 eq_refl) - (fun (a : A) (l0 : list A) - (IHl : forall (l' : list A) (d : A) (n : nat), - n < length l0 -> List.nth n (l0 ++ l') d = List.nth n l0 d) - (l' : list A) (d : A) (n0 : nat) => - nat_ind - (fun n : nat => - n < length (a :: l0) -> - List.nth n ((a :: l0) ++ l') d = List.nth n (a :: l0) d) - (fun _ : 0 < S (length l0) => eq_refl) - (fun (n : nat) - (_ : n < length (a :: l0) -> - List.nth n ((a :: l0) ++ l') d = List.nth n (a :: l0) d) - (H : S n < S (length l0)) => - IHl l' d n (Gt.gt_le_S n (length l0) (Lt.lt_S_n n (length l0) H))) n0) - l. - Lemma test_app_nth1 : actual_app_nth1 = expected_app_nth1. Proof. reflexivity. Qed. - - Preprocess List.app_nth2 as actual_app_nth2. - Definition expected_app_nth2 (A : Type) (l : list A) : - forall (l' : list A) (d : A) (n : nat), - n >= length l -> List.nth n (l ++ l') d = List.nth (n - length l) l' d - := - list_ind - (fun l0 : list A => - forall (l' : list A) (d : A) (n : nat), - n >= length l0 -> List.nth n (l0 ++ l') d = List.nth (n - length l0) l' d) - (fun (l' : list A) (d : A) (n0 : nat) => - nat_ind - (fun n : nat => - n >= length nil -> - List.nth n (nil ++ l') d = List.nth (n - length nil) l' d) - (fun _ : 0 >= length nil => eq_refl) - (fun (n : nat) - (_ : n >= length nil -> - List.nth n (nil ++ l') d = List.nth (n - length nil) l' d) - (_ : S n >= length nil) => eq_refl) n0) - (fun (a : A) (l0 : list A) - (IHl : forall (l' : list A) (d : A) (n : nat), - n >= length l0 -> - List.nth n (l0 ++ l') d = List.nth (n - length l0) l' d) - (l' : list A) (d : A) (n0 : nat) => - nat_ind - (fun n : nat => - n >= length (a :: l0) -> - List.nth n ((a :: l0) ++ l') d = List.nth (n - length (a :: l0)) l' d) - (fun H : 0 >= length (a :: l0) => - let H0 : - 0 = 0 -> - List.nth 0 ((a :: l0) ++ l') d = List.nth (0 - length (a :: l0)) l' d := - le_ind (length (a :: l0)) - (fun n : nat => - n = 0 -> - List.nth 0 ((a :: l0) ++ l') d = - List.nth (0 - length (a :: l0)) l' d) - (fun H0 : length (a :: l0) = 0 => - (fun H1 : length (a :: l0) = 0 => - let H2 : False := - eq_ind (length (a :: l0)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind - (List.nth 0 ((a :: l0) ++ l') d = - List.nth (0 - length (a :: l0)) l' d) H2) H0) - (fun (m : nat) (H0 : length (a :: l0) <= m) - (_ : m = 0 -> - List.nth 0 ((a :: l0) ++ l') d = - List.nth (0 - length (a :: l0)) l' d) - (H1 : S m = 0) => - (fun H2 : S m = 0 => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H2 in - False_ind - (length (a :: l0) <= m -> - List.nth 0 ((a :: l0) ++ l') d = - List.nth (0 - length (a :: l0)) l' d) H3) H1 H0) 0 H in - H0 eq_refl) - (fun (n : nat) - (_ : n >= length (a :: l0) -> - List.nth n ((a :: l0) ++ l') d = - List.nth (n - length (a :: l0)) l' d) - (H : S n >= length (a :: l0)) => - eq_ind_r (fun a0 : A => a0 = List.nth (n - length l0) l' d) eq_refl - (IHl l' d n (Gt.gt_S_le (length l0) n H))) n0) l. - Lemma test_app_nth2 : actual_app_nth2 = expected_app_nth2. Proof. reflexivity. Qed. - - Preprocess List.nth_split as actual_nth_split. - Definition expected_nth_split (A : Type) (n : nat) (l : list A) (d : A) : - n < length l -> exists l1 l2 : list A, l = (l1 ++ List.nth n l d :: l2) /\ length l1 = n - := - nat_ind - (fun n0 : nat => - forall l0 : list A, - n0 < length l0 -> - exists l1 l2 : list A, - l0 = (l1 ++ List.nth n0 l0 d :: l2) /\ length l1 = n0) - (fun l0 : list A => - list_ind - (fun l1 : list A => - 0 < length l1 -> - exists l2 l3 : list A, - l1 = (l2 ++ List.nth 0 l1 d :: l3) /\ length l2 = 0) - (fun H : 0 < length nil => - let H0 : - length nil = length nil -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth 0 nil d :: l2) /\ length l1 = 0 := - le_ind 1 - (fun n0 : nat => - n0 = length nil -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth 0 nil d :: l2) /\ length l1 = 0) - (fun H0 : 1 = length nil => - (fun H1 : 1 = length nil => - let H2 : False := - eq_ind 1 - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H1 in - False_ind - (exists l1 l2 : list A, - nil = (l1 ++ List.nth 0 nil d :: l2) /\ length l1 = 0) - H2) H0) - (fun (m : nat) (H0 : 1 <= m) - (_ : m = length nil -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth 0 nil d :: l2) /\ - length l1 = 0) (H1 : S m = length nil) => - (fun H2 : S m = length nil => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H2 in - False_ind - (1 <= m -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth 0 nil d :: l2) /\ length l1 = 0) - H3) H1 H0) (length nil) H in - H0 eq_refl) - (fun (a : A) (l1 : list A) - (_ : 0 < length l1 -> - exists l2 l3 : list A, - l1 = (l2 ++ List.nth 0 l1 d :: l3) /\ length l2 = 0) - (_ : 0 < length (a :: l1)) => - ex_intro - (fun l2 : list A => - exists l3 : list A, - (a :: l1) = (l2 ++ List.nth 0 (a :: l1) d :: l3) /\ - length l2 = 0) nil - (ex_intro - (fun l2 : list A => - (a :: l1) = (nil ++ List.nth 0 (a :: l1) d :: l2) /\ - length nil = 0) l1 (conj eq_refl eq_refl))) l0) - (fun (n0 : nat) - (IH : forall l0 : list A, - n0 < length l0 -> - exists l1 l2 : list A, - l0 = (l1 ++ List.nth n0 l0 d :: l2) /\ length l1 = n0) - (l0 : list A) => - list_ind - (fun l1 : list A => - S n0 < length l1 -> - exists l2 l3 : list A, - l1 = (l2 ++ List.nth (S n0) l1 d :: l3) /\ length l2 = S n0) - (fun H : S n0 < length nil => - let H0 : - length nil = length nil -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth (S n0) nil d :: l2) /\ length l1 = S n0 := - le_ind (S (S n0)) - (fun n1 : nat => - n1 = length nil -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth (S n0) nil d :: l2) /\ - length l1 = S n0) - (fun H0 : S (S n0) = length nil => - (fun H1 : S (S n0) = length nil => - let H2 : False := - eq_ind (S (S n0)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H1 in - False_ind - (exists l1 l2 : list A, - nil = (l1 ++ List.nth (S n0) nil d :: l2) /\ - length l1 = S n0) H2) H0) - (fun (m : nat) (H0 : S (S n0) <= m) - (_ : m = length nil -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth (S n0) nil d :: l2) /\ - length l1 = S n0) (H1 : S m = length nil) => - (fun H2 : S m = length nil => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H2 in - False_ind - (S (S n0) <= m -> - exists l1 l2 : list A, - nil = (l1 ++ List.nth (S n0) nil d :: l2) /\ - length l1 = S n0) H3) H1 H0) (length nil) H in - H0 eq_refl) - (fun (a : A) (l1 : list A) - (_ : S n0 < length l1 -> - exists l2 l3 : list A, - l1 = (l2 ++ List.nth (S n0) l1 d :: l3) /\ - length l2 = S n0) (H : S n0 < length (a :: l1)) => - let e : - exists l2 l3 : list A, - l1 = (l2 ++ List.nth n0 l1 d :: l3) /\ length l2 = n0 := - IH l1 (Gt.gt_le_S n0 (length l1) (Gt.gt_S_le (S n0) (length l1) H)) - in - ex_ind - (fun (l2 : list A) - (H0 : exists l3 : list A, - l1 = (l2 ++ List.nth n0 l1 d :: l3) /\ length l2 = n0) - => - ex_ind - (fun (l3 : list A) - (H1 : l1 = (l2 ++ List.nth n0 l1 d :: l3) /\ - length l2 = n0) => - and_ind - (fun (Hl : l1 = (l2 ++ List.nth n0 l1 d :: l3)) - (Hl1 : length l2 = n0) => - ex_intro - (fun l4 : list A => - exists l5 : list A, - (a :: l1) = - (l4 ++ List.nth (S n0) (a :: l1) d :: l5) /\ - length l4 = S n0) (a :: l2) - (ex_intro - (fun l4 : list A => - (a :: l1) = - ((a :: l2) ++ List.nth (S n0) (a :: l1) d :: l4) /\ - length (a :: l2) = S n0) l3 - (conj - (let H2 : l1 = (l2 ++ List.nth n0 l1 d :: l3) := - Hl in - (let H3 : a = a := eq_refl in - (let H4 : A = A := eq_refl in - (fun (_ : A = A) (_ : a = a) - (H7 : l1 = (l2 ++ List.nth n0 l1 d :: l3)) - => - eq_trans - (f_equal (fun f : list A -> list A => f l1) - eq_refl) (f_equal (cons a) H7)) H4) H3) H2) - (let H2 : length l2 = n0 := Hl1 in - (fun H3 : length l2 = n0 => - eq_trans - (f_equal (fun f : nat -> nat => f (length l2)) - eq_refl) (f_equal S H3)) H2)))) H1) H0) e) l0) - n l. - Lemma test_nth_split : actual_nth_split = expected_nth_split. Proof. reflexivity. Qed. - - Preprocess List.nth_error_In as actual_nth_error_In. - Definition expected_nth_error_In (A : Type) (l : list A) (n : nat) (x : A) : List.nth_error l n = Some x -> List.In x l := - list_ind - (fun l0 : list A => - forall n0 : nat, List.nth_error l0 n0 = Some x -> List.In x l0) - (fun n0 : nat => - nat_ind (fun n1 : nat => List.nth_error nil n1 = Some x -> List.In x nil) - (fun H : None = Some x => - let H0 : Some x = Some x -> False := - eq_ind None (fun y : option A => y = Some x -> False) - (fun H0 : None = Some x => - (fun H1 : None = Some x => - let H2 : False := - eq_ind None - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => False) True e) I - (Some x) H1 in - False_ind False H2) H0) (Some x) H in - H0 eq_refl) - (fun (n1 : nat) (_ : List.nth_error nil n1 = Some x -> List.In x nil) - (H : None = Some x) => - let H0 : Some x = Some x -> False := - eq_ind None (fun y : option A => y = Some x -> False) - (fun H0 : None = Some x => - (fun H1 : None = Some x => - let H2 : False := - eq_ind None - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => False) True e) I - (Some x) H1 in - False_ind False H2) H0) (Some x) H in - H0 eq_refl) n0) - (fun (a : A) (l0 : list A) - (IH : forall n0 : nat, List.nth_error l0 n0 = Some x -> List.In x l0) - (n0 : nat) => - nat_ind - (fun n1 : nat => - List.nth_error (a :: l0) n1 = Some x -> List.In x (a :: l0)) - (fun H : Some a = Some x => - let H0 : a = x := - f_equal - (fun e : option A => - option_rect (fun _ : option A => A) (fun a0 : A => a0) a e) H in - (fun H1 : a = x => or_introl H1) H0) - (fun (n1 : nat) - (_ : List.nth_error (a :: l0) n1 = Some x -> List.In x (a :: l0)) - (H : List.nth_error l0 n1 = Some x) => or_intror (IH n1 H)) n0) l n. - Lemma test_nth_error_In : actual_nth_error_In = expected_nth_error_In. Proof. reflexivity. Qed. - - Preprocess List.nth_error_None as actual_nth_error_None. - Definition expected_nth_error_None (A : Type) (l : list A) (n : nat) : List.nth_error l n = None <-> length l <= n := - list_ind - (fun l0 : list A => - forall n0 : nat, List.nth_error l0 n0 = None <-> length l0 <= n0) - (fun n0 : nat => - nat_ind - (fun n1 : nat => List.nth_error nil n1 = None <-> length nil <= n1) - (conj (fun _ : None = None => le_n 0) (fun _ : 0 <= 0 => eq_refl)) - (fun (n1 : nat) (_ : List.nth_error nil n1 = None <-> length nil <= n1) - => - conj (fun _ : None = None => le_S 0 n1 (PeanoNat.Nat.le_0_l n1)) - (fun _ : 0 <= S n1 => eq_refl)) n0) - (fun (a : A) (l0 : list A) - (IHl : forall n0 : nat, List.nth_error l0 n0 = None <-> length l0 <= n0) - (n0 : nat) => - nat_ind - (fun n1 : nat => - List.nth_error (a :: l0) n1 = None <-> length (a :: l0) <= n1) - (conj - (fun H : Some a = None => - let H0 : None = None -> S (length l0) <= 0 := - eq_ind (Some a) - (fun y : option A => y = None -> S (length l0) <= 0) - (fun H0 : Some a = None => - (fun H1 : Some a = None => - let H2 : False := - eq_ind (Some a) - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => True) False e) I None H1 in - False_ind (S (length l0) <= 0) H2) H0) None H in - H0 eq_refl) - (fun H : S (length l0) <= 0 => - let H0 : 0 = 0 -> Some a = None := - le_ind (S (length l0)) (fun n1 : nat => n1 = 0 -> Some a = None) - (fun H0 : S (length l0) = 0 => - (fun H1 : S (length l0) = 0 => - let H2 : False := - eq_ind (S (length l0)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind (Some a = None) H2) H0) - (fun (m : nat) (H0 : S (length l0) <= m) - (_ : m = 0 -> Some a = None) (H1 : S m = 0) => - (fun H2 : S m = 0 => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H2 in - False_ind (S (length l0) <= m -> Some a = None) H3) H1 H0) 0 H - in - H0 eq_refl)) - (fun (n1 : nat) - (_ : List.nth_error (a :: l0) n1 = None <-> length (a :: l0) <= n1) - => - (fun lemma : List.nth_error l0 n1 = None <-> length l0 <= n1 => - Morphisms.trans_co_eq_inv_impl_morphism RelationClasses.iff_Transitive - (List.nth_error l0 n1 = None) (length l0 <= n1) lemma - (S (length l0) <= S n1) (S (length l0) <= S n1) - (Morphisms.eq_proper_proxy (S (length l0) <= S n1))) - (IHl n1) - (conj - (fun H : length l0 <= n1 => - Gt.gt_le_S (length l0) (S n1) (Le.le_n_S (length l0) n1 H)) - (fun H : S (length l0) <= S n1 => Gt.gt_S_le (length l0) n1 H))) - n0) l n. - Lemma test_nth_error_None : actual_nth_error_None = expected_nth_error_None. Proof. reflexivity. Qed. - - Preprocess List.nth_error_Some as actual_nth_error_Some. - Definition expected_nth_error_Some (A : Type) (l : list A) (n : nat) : List.nth_error l n <> None <-> n < length l := - list_ind - (fun l0 : list A => - forall n0 : nat, List.nth_error l0 n0 <> None <-> n0 < length l0) - (fun n0 : nat => - nat_ind - (fun n1 : nat => List.nth_error nil n1 <> None <-> n1 < length nil) - (conj - (fun H : None <> None => - let n1 : False := H eq_refl in False_ind (0 < 0) n1) - (fun H : 0 < 0 => - let H0 : 0 = 0 -> None <> None := - le_ind 1 (fun n1 : nat => n1 = 0 -> None <> None) - (fun H0 : 1 = 0 => - (fun H1 : 1 = 0 => - let H2 : False := - eq_ind 1 - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind (None <> None) H2) H0) - (fun (m : nat) (H0 : 1 <= m) (_ : m = 0 -> None <> None) - (H1 : S m = 0) => - (fun H2 : S m = 0 => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H2 in - False_ind (1 <= m -> None <> None) H3) H1 H0) 0 H in - H0 eq_refl)) - (fun (n1 : nat) (_ : List.nth_error nil n1 <> None <-> n1 < length nil) - => - conj - (fun H : None <> None => - let n2 : False := H eq_refl in False_ind (S n1 < 0) n2) - (fun H : S n1 < 0 => - let H0 : 0 = 0 -> None <> None := - le_ind (S (S n1)) (fun n2 : nat => n2 = 0 -> None <> None) - (fun H0 : S (S n1) = 0 => - (fun H1 : S (S n1) = 0 => - let H2 : False := - eq_ind (S (S n1)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind (None <> None) H2) H0) - (fun (m : nat) (H0 : S (S n1) <= m) (_ : m = 0 -> None <> None) - (H1 : S m = 0) => - (fun H2 : S m = 0 => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H2 in - False_ind (S (S n1) <= m -> None <> None) H3) H1 H0) 0 H in - H0 eq_refl)) n0) - (fun (a : A) (l0 : list A) - (IHl : forall n0 : nat, List.nth_error l0 n0 <> None <-> n0 < length l0) - (n0 : nat) => - nat_ind - (fun n1 : nat => - List.nth_error (a :: l0) n1 <> None <-> n1 < length (a :: l0)) - (conj - (fun _ : Some a <> None => - Gt.gt_le_S 0 (S (length l0)) - (Lt.lt_le_S 0 (S (length l0)) (PeanoNat.Nat.lt_0_succ (length l0)))) - (fun (_ : 0 < S (length l0)) (H0 : Some a = None) => - let H1 : None = None -> False := - eq_ind (Some a) (fun y : option A => y = None -> False) - (fun H1 : Some a = None => - (fun H2 : Some a = None => - let H3 : False := - eq_ind (Some a) - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => True) False e) I None H2 in - False_ind False H3) H1) None H0 in - H1 eq_refl)) - (fun (n1 : nat) - (_ : List.nth_error (a :: l0) n1 <> None <-> n1 < length (a :: l0)) - => - (fun lemma : List.nth_error l0 n1 <> None <-> n1 < length l0 => - Morphisms.trans_co_eq_inv_impl_morphism RelationClasses.iff_Transitive - (List.nth_error l0 n1 <> None) (n1 < length l0) lemma - (S n1 < S (length l0)) (S n1 < S (length l0)) - (Morphisms.eq_proper_proxy (S n1 < S (length l0)))) - (IHl n1) - (conj - (fun H : n1 < length l0 => - Gt.gt_le_S (S n1) (S (length l0)) (Lt.lt_n_S n1 (length l0) H)) - (fun H : S n1 < S (length l0) => - Gt.gt_le_S n1 (length l0) (Gt.gt_S_le (S n1) (length l0) H)))) n0) - l n. - Lemma test_nth_error_Some : actual_nth_error_Some = expected_nth_error_Some. Proof. reflexivity. Qed. - - Preprocess List.nth_error_split as actual_nth_error_split. - Definition expected_nth_error_split (A : Type) (l : list A) (n : nat) (a : A) : - List.nth_error l n = Some a -> exists l1 l2 : list A, l = (l1 ++ a :: l2) /\ length l1 = n - := - nat_ind - (fun n0 : nat => - forall l0 : list A, - List.nth_error l0 n0 = Some a -> - exists l1 l2 : list A, l0 = (l1 ++ a :: l2) /\ length l1 = n0) - (fun l0 : list A => - list_ind - (fun l1 : list A => - List.nth_error l1 0 = Some a -> - exists l2 l3 : list A, l1 = (l2 ++ a :: l3) /\ length l2 = 0) - (fun H : List.nth_error nil 0 = Some a => - let H0 : - Some a = Some a -> - exists l1 l2 : list A, nil = (l1 ++ a :: l2) /\ length l1 = 0 := - eq_ind (List.nth_error nil 0) - (fun y : option A => - y = Some a -> - exists l1 l2 : list A, nil = (l1 ++ a :: l2) /\ length l1 = 0) - (fun H0 : None = Some a => - (fun H1 : None = Some a => - let H2 : False := - eq_ind None - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => False) True e) I - (Some a) H1 in - False_ind - (exists l1 l2 : list A, - nil = (l1 ++ a :: l2) /\ length l1 = 0) H2) H0) - (Some a) H in - H0 eq_refl) - (fun (x : A) (l1 : list A) - (_ : List.nth_error l1 0 = Some a -> - exists l2 l3 : list A, - l1 = (l2 ++ a :: l3) /\ length l2 = 0) - (H : List.nth_error (x :: l1) 0 = Some a) => - ex_intro - (fun l2 : list A => - exists l3 : list A, - (x :: l1) = (l2 ++ a :: l3) /\ length l2 = 0) nil - (ex_intro - (fun l2 : list A => - (x :: l1) = (nil ++ a :: l2) /\ length nil = 0) l1 - (let H0 : x = a := - f_equal - (fun e : option A => - option_rect (fun _ : option A => A) (fun a0 : A => a0) x e) - H in - (fun H1 : x = a => - eq_ind_r - (fun x0 : A => - (x0 :: l1) = (nil ++ a :: l1) /\ length nil = 0) - (conj eq_refl eq_refl) H1) H0))) l0) - (fun (n0 : nat) - (IH : forall l0 : list A, - List.nth_error l0 n0 = Some a -> - exists l1 l2 : list A, l0 = (l1 ++ a :: l2) /\ length l1 = n0) - (l0 : list A) => - list_ind - (fun l1 : list A => - List.nth_error l1 (S n0) = Some a -> - exists l2 l3 : list A, l1 = (l2 ++ a :: l3) /\ length l2 = S n0) - (fun H : List.nth_error nil (S n0) = Some a => - let H0 : - Some a = Some a -> - exists l1 l2 : list A, nil = (l1 ++ a :: l2) /\ length l1 = S n0 := - eq_ind (List.nth_error nil (S n0)) - (fun y : option A => - y = Some a -> - exists l1 l2 : list A, - nil = (l1 ++ a :: l2) /\ length l1 = S n0) - (fun H0 : None = Some a => - (fun H1 : None = Some a => - let H2 : False := - eq_ind None - (fun e : option A => - option_rect (fun _ : option A => Prop) - (fun _ : A => False) True e) I - (Some a) H1 in - False_ind - (exists l1 l2 : list A, - nil = (l1 ++ a :: l2) /\ length l1 = S n0) H2) H0) - (Some a) H in - H0 eq_refl) - (fun (x : A) (l1 : list A) - (_ : List.nth_error l1 (S n0) = Some a -> - exists l2 l3 : list A, - l1 = (l2 ++ a :: l3) /\ length l2 = S n0) - (H : List.nth_error (x :: l1) (S n0) = Some a) => - let e : - exists l2 l3 : list A, l1 = (l2 ++ a :: l3) /\ length l2 = n0 := - IH l1 H in - ex_ind - (fun (l2 : list A) - (H0 : exists l3 : list A, - l1 = (l2 ++ a :: l3) /\ length l2 = n0) => - ex_ind - (fun (l3 : list A) - (H1 : l1 = (l2 ++ a :: l3) /\ length l2 = n0) => - and_ind - (fun (H2 : l1 = (l2 ++ a :: l3)) (H3 : length l2 = n0) => - ex_intro - (fun l4 : list A => - exists l5 : list A, - (x :: l1) = (l4 ++ a :: l5) /\ length l4 = S n0) - (x :: l2) - (ex_intro - (fun l4 : list A => - (x :: l1) = ((x :: l2) ++ a :: l4) /\ - length (x :: l2) = S n0) l3 - (conj - (let H4 : l1 = (l2 ++ a :: l3) := H2 in - (let H5 : x = x := eq_refl in - (let H6 : A = A := eq_refl in - (fun (_ : A = A) (_ : x = x) - (H9 : l1 = (l2 ++ a :: l3)) => - eq_trans - (f_equal (fun f : list A -> list A => f l1) - eq_refl) (f_equal (cons x) H9)) H6) H5) H4) - (let H4 : length l2 = n0 := H3 in - (fun H5 : length l2 = n0 => - eq_trans - (f_equal (fun f : nat -> nat => f (length l2)) - eq_refl) (f_equal S H5)) H4)))) H1) H0) e) l0) - n l. - Lemma test_nth_error_split : actual_nth_error_split = expected_nth_error_split. Proof. reflexivity. Qed. - - Preprocess List.nth_error_app1 as actual_nth_error_app1. - Definition expected_nth_error_app1 (A : Type) (l l' : list A) (n : nat) : - n < length l -> List.nth_error (l ++ l') n = List.nth_error l n - := - nat_ind - (fun n0 : nat => - forall l0 : list A, - n0 < length l0 -> List.nth_error (l0 ++ l') n0 = List.nth_error l0 n0) - (fun l0 : list A => - list_ind - (fun l1 : list A => - 0 < length l1 -> List.nth_error (l1 ++ l') 0 = List.nth_error l1 0) - (fun H : 0 < length nil => - let H0 : - length nil = length nil -> - List.nth_error (nil ++ l') 0 = List.nth_error nil 0 := - le_ind 1 - (fun n0 : nat => - n0 = length nil -> - List.nth_error (nil ++ l') 0 = List.nth_error nil 0) - (fun H0 : 1 = length nil => - (fun H1 : 1 = length nil => - let H2 : False := - eq_ind 1 - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H1 in - False_ind (List.nth_error (nil ++ l') 0 = List.nth_error nil 0) - H2) H0) - (fun (m : nat) (H0 : 1 <= m) - (_ : m = length nil -> - List.nth_error (nil ++ l') 0 = List.nth_error nil 0) - (H1 : S m = length nil) => - (fun H2 : S m = length nil => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H2 in - False_ind - (1 <= m -> List.nth_error (nil ++ l') 0 = List.nth_error nil 0) - H3) H1 H0) (length nil) H in - H0 eq_refl) - (fun (a : A) (l1 : list A) - (_ : 0 < length l1 -> - List.nth_error (l1 ++ l') 0 = List.nth_error l1 0) - (_ : 0 < length (a :: l1)) => eq_refl) l0) - (fun (n0 : nat) - (IHn : forall l0 : list A, - n0 < length l0 -> - List.nth_error (l0 ++ l') n0 = List.nth_error l0 n0) - (l0 : list A) => - list_ind - (fun l1 : list A => - S n0 < length l1 -> - List.nth_error (l1 ++ l') (S n0) = List.nth_error l1 (S n0)) - (fun H : S n0 < length nil => - let H0 : - length nil = length nil -> - List.nth_error (nil ++ l') (S n0) = List.nth_error nil (S n0) := - le_ind (S (S n0)) - (fun n1 : nat => - n1 = length nil -> - List.nth_error (nil ++ l') (S n0) = List.nth_error nil (S n0)) - (fun H0 : S (S n0) = length nil => - (fun H1 : S (S n0) = length nil => - let H2 : False := - eq_ind (S (S n0)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H1 in - False_ind - (List.nth_error (nil ++ l') (S n0) = List.nth_error nil (S n0)) - H2) H0) - (fun (m : nat) (H0 : S (S n0) <= m) - (_ : m = length nil -> - List.nth_error (nil ++ l') (S n0) = - List.nth_error nil (S n0)) (H1 : S m = length nil) => - (fun H2 : S m = length nil => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I - (length nil) H2 in - False_ind - (S (S n0) <= m -> - List.nth_error (nil ++ l') (S n0) = List.nth_error nil (S n0)) - H3) H1 H0) (length nil) H in - H0 eq_refl) - (fun (a : A) (l1 : list A) - (_ : S n0 < length l1 -> - List.nth_error (l1 ++ l') (S n0) = List.nth_error l1 (S n0)) - (H : S n0 < length (a :: l1)) => - IHn l1 (Gt.gt_le_S n0 (length l1) (Gt.gt_S_le (S n0) (length l1) H))) - l0) n l. - Lemma test_nth_error_app1 : actual_nth_error_app1 = expected_nth_error_app1. Proof. reflexivity. Qed. - - Preprocess List.nth_error_app2 as actual_nth_error_app2. - Definition expected_nth_error_app2 (A : Type) (l l' : list A) (n : nat) : - length l <= n -> List.nth_error (l ++ l') n = List.nth_error l' (n - length l) - := - nat_ind - (fun n0 : nat => - forall l0 : list A, - length l0 <= n0 -> - List.nth_error (l0 ++ l') n0 = List.nth_error l' (n0 - length l0)) - (fun l0 : list A => - list_ind - (fun l1 : list A => - length l1 <= 0 -> - List.nth_error (l1 ++ l') 0 = List.nth_error l' (0 - length l1)) - (fun _ : length nil <= 0 => eq_refl) - (fun (a : A) (l1 : list A) - (_ : length l1 <= 0 -> - List.nth_error (l1 ++ l') 0 = List.nth_error l' (0 - length l1)) - (H : length (a :: l1) <= 0) => - let H0 : - 0 = 0 -> - List.nth_error ((a :: l1) ++ l') 0 = - List.nth_error l' (0 - length (a :: l1)) := - le_ind (length (a :: l1)) - (fun n0 : nat => - n0 = 0 -> - List.nth_error ((a :: l1) ++ l') 0 = - List.nth_error l' (0 - length (a :: l1))) - (fun H0 : length (a :: l1) = 0 => - (fun H1 : length (a :: l1) = 0 => - let H2 : False := - eq_ind (length (a :: l1)) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H1 in - False_ind - (List.nth_error ((a :: l1) ++ l') 0 = - List.nth_error l' (0 - length (a :: l1))) H2) H0) - (fun (m : nat) (H0 : length (a :: l1) <= m) - (_ : m = 0 -> - List.nth_error ((a :: l1) ++ l') 0 = - List.nth_error l' (0 - length (a :: l1))) - (H1 : S m = 0) => - (fun H2 : S m = 0 => - let H3 : False := - eq_ind (S m) - (fun e : nat => - nat_rect (fun _ : nat => Prop) False - (fun (_ : nat) (_ : Prop) => True) e) I 0 H2 in - False_ind - (length (a :: l1) <= m -> - List.nth_error ((a :: l1) ++ l') 0 = - List.nth_error l' (0 - length (a :: l1))) H3) H1 H0) 0 H in - H0 eq_refl) l0) - (fun (n0 : nat) - (IHn : forall l0 : list A, - length l0 <= n0 -> - List.nth_error (l0 ++ l') n0 = List.nth_error l' (n0 - length l0)) - (l0 : list A) => - list_ind - (fun l1 : list A => - length l1 <= S n0 -> - List.nth_error (l1 ++ l') (S n0) = List.nth_error l' (S n0 - length l1)) - (fun _ : length nil <= S n0 => eq_refl) - (fun (a : A) (l1 : list A) - (_ : length l1 <= S n0 -> - List.nth_error (l1 ++ l') (S n0) = - List.nth_error l' (S n0 - length l1)) - (H : length (a :: l1) <= S n0) => - IHn l1 (Gt.gt_S_le (length l1) n0 H)) l0) n l. - Lemma test_nth_error_app2 : actual_nth_error_app2 = expected_nth_error_app2. Proof. reflexivity. Qed. - - Preprocess List.remove as actual_remove. - Definition expected_remove (A : Type) (eq_dec : forall x y : A, {x = y} + {x <> y}) (x : A) (l : list A) : list A := - list_rect (fun _ : list A => A -> list A) (fun _ : A => nil) - (fun (r : A) (_ : list A) (remove : A -> list A) (x0 : A) => - sumbool_rect (fun _ : {x0 = r} + {x0 <> r} => list A) - (fun _ : x0 = r => remove x0) (fun _ : x0 <> r => (r :: remove x0)) - (eq_dec x0 r)) l x. - Lemma test_remove : actual_remove = expected_remove. Proof. reflexivity. Qed. - - Preprocess List.last as actual_last. - Definition expected_last (A : Type) (l : list A) : A -> A := - list_rect (fun _ : list A => A -> A) (fun d : A => d) - (fun (a : A) (l0 : list A) (last : A -> A) (d : A) => - list_rect (fun _ : list A => A) a - (fun (_ : A) (_ : list A) (_ : A) => last d) l0) l. - Lemma test_last : actual_last = expected_last. Proof. reflexivity. Qed. - - Preprocess List.removelast as actual_removelast. - Definition expected_removelast (A : Type) (l : list A) : list A := - list_rect (fun _ : list A => list A) nil - (fun (a : A) (l0 removelast : list A) => - list_rect (fun _ : list A => list A) nil - (fun (_ : A) (_ _ : list A) => (a :: removelast)) l0) l. - Lemma test_removelast : actual_removelast = expected_removelast. Proof. reflexivity. Qed. - - Preprocess List.app_removelast_last as actual_app_removelast_last. - Definition expected_app_removelast_last (A : Type) (l : list A) : - forall (d : A), l <> nil -> l = (List.removelast l ++ List.last l d :: nil) - := - list_ind - (fun l0 : list A => - forall d : A, - l0 <> nil -> l0 = (List.removelast l0 ++ List.last l0 d :: nil)) - (fun (d : A) (H : nil <> nil) => - let n : False := H eq_refl in - False_ind (nil = (List.removelast nil ++ List.last nil d :: nil)) n) - (fun (a : A) (l0 : list A) - (IHl : forall d : A, - l0 <> nil -> - l0 = (List.removelast l0 ++ List.last l0 d :: nil)) - (d : A) (_ : (a :: l0) <> nil) => - list_ind - (fun l1 : list A => - (forall d0 : A, - l1 <> nil -> l1 = (List.removelast l1 ++ List.last l1 d0 :: nil)) -> - (a :: l1) = - (List.removelast (a :: l1) ++ List.last (a :: l1) d :: nil)) - (fun - _ : forall d0 : A, - nil <> nil -> - nil = (List.removelast nil ++ List.last nil d0 :: nil) => - eq_refl) - (fun (a0 : A) (l1 : list A) - (_ : (forall d0 : A, - l1 <> nil -> - l1 = (List.removelast l1 ++ List.last l1 d0 :: nil)) -> - (a :: l1) = - (List.removelast (a :: l1) ++ List.last (a :: l1) d :: nil)) - (IHl0 : forall d0 : A, - (a0 :: l1) <> nil -> - (a0 :: l1) = - (List.removelast (a0 :: l1) ++ List.last (a0 :: l1) d0 :: nil)) - => - eq_ind_r - (fun l2 : list A => - (a :: l2) = - (List.removelast (a :: a0 :: l1) ++ - List.last (a :: a0 :: l1) d :: nil)) eq_refl - (IHl0 d - (fun H : (a0 :: l1) = nil => - let H0 : False := - eq_ind (a0 :: l1) - (fun e : list A => - list_rect (fun _ : list A => Prop) False - (fun (_ : A) (_ : list A) (_ : Prop) => True) e) I nil H - in - False_ind False H0))) l0 IHl) l. - Lemma test_app_removelast_last : actual_app_removelast_last = expected_app_removelast_last. Proof. reflexivity. Qed. - - Preprocess List.exists_last as actual_exists_last. - Definition expected_exists_last (A : Type) (l : list A) : l <> nil -> {l' : list A & {a : A | l = (l' ++ a :: nil)}} := - list_rect - (fun l0 : list A => - l0 <> nil -> {l' : list A & {a : A | l0 = (l' ++ a :: nil)}}) - (fun H : nil <> nil => - let n : False := H eq_refl in - False_rect {l' : list A & {a : A | nil = (l' ++ a :: nil)}} n) - (fun (a : A) (l0 : list A) - (IHl : l0 <> nil -> - {l' : list A & {a0 : A | l0 = (l' ++ a0 :: nil)}}) - (_ : (a :: l0) <> nil) => - list_rect - (fun l1 : list A => - (l1 <> nil -> {l' : list A & {a0 : A | l1 = (l' ++ a0 :: nil)}}) -> - {l' : list A & {a0 : A | (a :: l1) = (l' ++ a0 :: nil)}}) - (fun - _ : nil <> nil -> - {l' : list A & {a0 : A | nil = (l' ++ a0 :: nil)}} => - existT - (fun l' : list A => - {a0 : A | (a :: nil) = (l' ++ a0 :: nil)}) nil - (exist (fun a0 : A => (a :: nil) = (nil ++ a0 :: nil)) a - eq_refl)) - (fun (a0 : A) (l1 : list A) - (_ : (l1 <> nil -> - {l' : list A & {a1 : A | l1 = (l' ++ a1 :: nil)}}) -> - {l' : list A & - {a1 : A | (a :: l1) = (l' ++ a1 :: nil)}}) - (IHl0 : (a0 :: l1) <> nil -> - {l' : list A & - {a1 : A | (a0 :: l1) = (l' ++ a1 :: nil)}}) => - let s := - IHl0 - (fun H : (a0 :: l1) = nil => - let H0 : False := - eq_ind (a0 :: l1) - (fun e : list A => - list_rect (fun _ : list A => Prop) False - (fun (_ : A) (_ : list A) (_ : Prop) => True) e) I nil H in - False_ind False H0) in - sigT_rect - (fun - _ : {l' : list A & - {a1 : A | (a0 :: l1) = (l' ++ a1 :: nil)}} => - {l' : list A & - {a1 : A | (a :: a0 :: l1) = (l' ++ a1 :: nil)}}) - (fun (l' : list A) - (s0 : {a1 : A | (a0 :: l1) = (l' ++ a1 :: nil)}) => - sig_rect - (fun _ : {a1 : A | (a0 :: l1) = (l' ++ a1 :: nil)} => - {l'0 : list A & - {a1 : A | (a :: a0 :: l1) = (l'0 ++ a1 :: nil)}}) - (fun (a' : A) (H : (a0 :: l1) = (l' ++ a' :: nil)) => - eq_rect_r - (fun l2 : list A => - {l'0 : list A & - {a1 : A | (a :: l2) = (l'0 ++ a1 :: nil)}}) - (existT - (fun l'0 : list A => - {a1 : A | - (a :: l' ++ a' :: nil) = (l'0 ++ a1 :: nil)}) - (a :: l') - (exist - (fun a1 : A => - (a :: l' ++ a' :: nil) = - ((a :: l') ++ a1 :: nil)) a' eq_refl)) H) s0) s) l0 - IHl) l. - Lemma test_exists_last : actual_exists_last = expected_exists_last. Proof. reflexivity. Qed. - - Preprocess List.list_power as actual_list_power. - Definition expected_list_power (A B : Type) (l : list A) : list B -> list (list (A * B)) := - list_rect - (fun _ : list A => forall B0 : Type, list B0 -> list (list (A * B0))) - (fun (B0 : Type) (_ : list B0) => (nil :: nil)%list) - (fun (l0 : A) (_ : list A) - (list_power : forall B0 : Type, list B0 -> list (list (A * B0))) - (B0 : Type) (l' : list B0) => - List.flat_map - (fun f : list (A * B0) => - List.map (fun y : B0 => ((l0, y) :: f)%list) l') - (list_power B0 l')) l B. - Lemma test_list_power : actual_list_power = expected_list_power. Proof. reflexivity. Qed. - -End ListTests. diff --git a/plugin/coq/PreprocessModule.v b/plugin/coq/PreprocessModule.v deleted file mode 100644 index b3c3191..0000000 --- a/plugin/coq/PreprocessModule.v +++ /dev/null @@ -1,15 +0,0 @@ -Require Import Patcher.Patch. -Require List. - -(* - * Test whole module preprocessing to convert fixpoints - * to induction principles. By Nate Yazdani, from DEVOID. - *) - -(* - * NOTE: Any serious bug is likely to cause a typing error, and comparing the - * exact output against some reference would give negligible further assurance - * at the cost of unwieldiness. It would be very difficult to translate terms - * only partially while preserving well-typedness. - *) -Preprocess Module List as List' {include length, app}. diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim new file mode 160000 index 0000000..7fa57cf --- /dev/null +++ b/plugin/deps/fix-to-elim @@ -0,0 +1 @@ +Subproject commit 7fa57cfd01331251f46638ca5fcedce899251316 diff --git a/plugin/src/core/procedures/desugar.ml b/plugin/src/core/procedures/desugar.ml deleted file mode 100644 index c1d9d1e..0000000 --- a/plugin/src/core/procedures/desugar.ml +++ /dev/null @@ -1,408 +0,0 @@ -(* - * Translation of fixpoints and match statements to induction principles. - * By Nate Yazdani, taken from the DEVOID code. - *) - -open Util -open Names -open Univ -open Context -open Term -open Constr -open Inductiveops -open CErrors -open Coqterms -open Abstraction -open Environ - -(* - * Pair the outputs of two functions on the same input. - *) -let pair f g = - fun x -> f x, g x - -(* - * Convenient wrapper around Vars.liftn shift (skip + 1) term. - *) -let lift_rels ?(skip=0) shift term = - Vars.liftn shift (skip + 1) term - -(* - * Same as lift_rels ~skip:skip 1. - *) -let lift_rel ?(skip=0) = lift_rels ~skip:skip 1 - -(* - * Convenient wrapper around Vars.liftn (-shift) (skip + 1) term. - *) -let drop_rels ?(skip=0) shift term = - assert (Vars.noccur_between (skip + 1) (skip + shift) term); - Vars.liftn (-shift) (skip + 1) term - -(* - * Same as drop_rels ~skip:skip 1. - *) -let drop_rel ?(skip=0) = drop_rels ~skip:skip 1 - -(* - * Function from: - * https://github.com/coq/coq/commit/7ada864b7728c9c94b7ca9856b6b2c89feb0214e - * Inlined here to make this compatible with Coq 8.8.0 - *) -let fold_constr_with_binders g f n acc c = - match kind c with - | (Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ - | Construct _) -> acc - | Cast (c,_, t) -> f n (f n acc c) t - | Prod (na,t,c) -> f (g n) (f n acc t) c - | Lambda (na,t,c) -> f (g n) (f n acc t) c - | LetIn (na,b,t,c) -> f (g n) (f n (f n acc b) t) c - | App (c,l) -> Array.fold_left (f n) (f n acc c) l - | Proj (p,c) -> f n acc c - | Evar (_,l) -> Array.fold_left (f n) acc l - | Case (_,p,c,bl) -> Array.fold_left (f n) (f n (f n acc p) c) bl - | Fix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - | CoFix (_,(lna,tl,bl)) -> - let n' = CArray.fold_left2 (fun c n t -> g c) n lna tl in - let fd = Array.map2 (fun t b -> (t,b)) tl bl in - Array.fold_left (fun acc (t,b) -> f n' (f n acc t) b) acc fd - -(* - * Gather the set of relative (de Bruijn) variables occurring in the term that - * are free (i.e., not bound) under nb levels of external relative binding. - * - * Use free_rels 0 Int.Set.empty if you do not wish to filter out any free - * relative variables below a certain binding level (nb) or supply the initial - * accumulator (frels). - * - * Examples: - * - free_rels 0 {} (Lambda(_, Rel 2, App(Rel 2, [Rel 1; Rel 4]))) = { 1, 2, 3 } - * - free_rels 1 {} (Lambda(_, Rel 2, App(Rel 2, [Rel 1; Rel 4]))) = { 2, 3 } - * - free_rels 2 {} (Lambda(_, Rel 2, App(Rel 2, [Rel 1; Rel 4]))) = { 3 } - *) -let rec free_rels nb frels term = - match Constr.kind term with - | Rel i -> - if i > nb then Int.Set.add (Debruijn.unshift_i_by nb i) frels else frels - | _ -> - fold_constr_with_binders succ free_rels nb frels term - -(* - * Give a "reasonable" name to each anonymous local declaration in the relative - * context. Name generation is according to standard Coq policy (cf., Namegen) - * and does not guarantee freshness, but term type-checking is only sensitive to - * anonymity. (Names are freshened by subscription when printed.) - *) -let deanonymize_context env evm ctxt = - List.map EConstr.of_rel_decl ctxt |> - Namegen.name_context env evm |> - List.map (EConstr.to_rel_decl evm) - -(* - * Instantiate a local assumption as a local definition, using the provided term - * as its definition. - * - * Raises an assertion error if the local declaration is not a local assumption. - *) -let define_rel_decl body decl = - assert (is_rel_assum decl); - rel_defin (rel_name decl, body, rel_type decl) - -(* - * Extract the components of an inductive type: the (universe-instantiated) - * inductive name, the sequence of parameters, and the sequence of indices. - *) -let decompose_indvect ind_type = - let pind, args = decompose_appvect ind_type |> on_fst destInd in - let nparam = inductive_nparams (out_punivs pind) in - let params, indices = Array.chop nparam args in - pind, params, indices - -(* - * Same as decompose_indvect but converts the result arrays into lists. - *) -let decompose_ind ind_type = - decompose_indvect ind_type |> on_pi2 Array.to_list |> on_pi3 Array.to_list - -(* - * Construct a relative context, consisting of only local assumptions, - * quantifying over instantiations of the inductive family. - * - * In other words, the output relative context assumes all indices (in standard - * order) and then a value of the inductive type (at those indices). - * - * Note that an inductive family is an inductive name with parameter terms. - *) -let build_inductive_context env ind_fam ind_name = - let ind_type = build_dependent_inductive env ind_fam in - let ind_decl = rel_assum (ind_name, ind_type) in - get_arity env ind_fam |> fst |> Rel.add ind_decl |> Termops.smash_rel_context - -(* - * Transform the relative context of a fixed-point function into a form suitable - * for simple recursion (i.e., eliminator-style quantification). - * - * The transformed relative context only satisfies that guarantee (or even - * well-formedness) when immediately preceded by the quantifying relative - * context for the inductive type and then by a wrapping relative context - * for the fixed point. - *) -let build_recursive_context fix_ctxt params indices = - let nb = Rel.length fix_ctxt in (* length of fixed-point context *) - let nb' = nb + List.length indices + 1 in (* length of recursive context *) - let par_rels = List.fold_left (free_rels 0) Int.Set.empty params in - let idx_rels = 1 :: List.rev_map destRel indices in - (* NOTE: DestKO raised (above) if any index was not bound fully abstracted. *) - let is_rec i = i <= nb in - let is_par i = not (Int.Set.mem i par_rels) in (* parameter independence *) - assert (List.for_all is_rec idx_rels); (* Is every index bound recursively? *) - assert (List.distinct idx_rels); (* Are the indices bound separately and... *) - assert (List.for_all is_par idx_rels); (* ...independently of parameters? *) - (* Abstract inductive quantification to the outer inductive context *) - let buf = Termops.lift_rel_context nb' fix_ctxt |> Array.of_list in - let abstract_rel j i = buf.(i - 1) <- define_rel_decl (mkRel j) buf.(i - 1) in - (* Abstract each parameter-relevant binding to the wrapper context. *) - Int.Set.iter (abstract_rel nb') (Int.Set.filter is_rec par_rels); - (* Abstract the remaining inductive bindings to the eliminator context. *) - List.iter2 abstract_rel (List.map_i (-) (nb + 1) idx_rels) idx_rels; - Array.to_list buf - -(* - * Build the minor premise for elimination at a constructor from the - * corresponding fixed-point case. - * - * In particular, insert recurrence bindings (for inductive hypotheses) in the - * appropriate positions, substituting recursive calls with the recurrence - * binding its value. - * - * The last argument provides the case's parameter context (quantifying - * constructor arguments) with the case's body term. - *) -let premise_of_case env ind_fam (ctxt, body) = - let nb = Rel.length ctxt in - let ind_head = dest_ind_family ind_fam |> on_fst mkIndU |> applist in - let fix_name, fix_type = Environ.lookup_rel 1 env |> pair rel_name rel_type in - let insert_recurrence i body decl = - let i = Debruijn.unshift_i_by i nb in - let j = Debruijn.shift_i i in - let body' = - match eq_constr_head (lift_rels i ind_head) (rel_type decl) with - | Some indices -> - assert (is_rel_assum decl); - let args = Array.append (Array.map lift_rel indices) [|mkRel 1|] in - let rec_type = prod_appvect (lift_rels j fix_type) args in - let fix_call = mkApp (mkRel j, args) in - mkLambda (fix_name, rec_type, abstract_subterm fix_call body) - | _ -> - body - in - mkLambda_or_LetIn decl body' - in - List.fold_left_i insert_recurrence 0 body ctxt - -(* - * Given a constructor summary (cf., Inductiveops), build a parameter context - * to quantify over constructor arguments (and thus values of that constructor) - * and partially evaluate the functional applied to the constructed value's type - * indices and (subsequently) to the constructed value itself. - * - * Partial evaluation reduces to beta/iota-normal form. Exclusion of delta - * reduction is intentional (rarely beneficial, usually detrimental). - *) -let split_case env evm fun_term cons_sum = - let cons = build_dependent_constructor cons_sum in - let env = Environ.push_rel_context cons_sum.cs_args env in - let body = - let head = lift_rels cons_sum.cs_nargs fun_term in - let args = Array.append cons_sum.cs_concl_realargs [|cons|] in - mkApp (head, args) |> Reduction.nf_betaiota env - in - deanonymize_context env evm cons_sum.cs_args, body - -(* - * Eta-expand a case term according to the corresponding constructor's type. - *) -let expand_case env evm case_term cons_sum = - let body = - let head = lift_rels cons_sum.cs_nargs case_term in - let args = Rel.to_extended_list mkRel 0 cons_sum.cs_args in - Reduction.beta_applist head args - in - deanonymize_context env evm cons_sum.cs_args, body - -(* - * Build an elimination head (partially applied eliminator) including the - * parameters and (sort-adjusted) motive for the given inductive family and - * (dependent) elimination type. - * - * The sorts of the inductive family and of the elimination type are considered, - * respectively, when adjusting the elimination type into a motive (by removing - * dependency for Prop-sorted inductive families) and when selecting one of the - * inductive family's eliminators. - * - * NOTE: Motive adjustment might be too overzealous; under some particular - * conditions, Coq does allow dependency in the elimination motive for a Prop- - * sorted inductive family. - *) -let configure_eliminator env evm ind_fam typ = - let ind, params = dest_ind_family ind_fam |> on_fst out_punivs in - let nb = inductive_nrealargs ind + 1 in - let typ_ctxt, typ_body = - let typ_ctxt, typ_body = decompose_prod_n_assum nb typ in - let ind_sort = get_arity env ind_fam |> snd in - if Sorts.family_equal ind_sort Sorts.InProp then - List.tl typ_ctxt, drop_rel typ_body - else - typ_ctxt, typ_body - in - let elim = - let typ_env = Environ.push_rel_context typ_ctxt env in - let typ_sort = e_infer_sort typ_env evm typ_body in - Indrec.lookup_eliminator ind typ_sort |> e_new_global evm - in - let motive = recompose_lam_assum typ_ctxt typ_body in - mkApp (elim, Array.append (Array.of_list params) [|motive|]) - -(* - * Translate a fixed-point function using simple recursion (i.e., quantifying - * the inductive type like an eliminator) into an elimination form. - *) -let desugar_recursion env evm ind_fam fix_name fix_type fix_term = - (* Build the elimination head (eliminator with parameters and motive) *) - let elim_head = configure_eliminator env evm ind_fam fix_type in - (* Build the minor premises *) - let premises = - let fix_env = Environ.push_rel (rel_assum (fix_name, fix_type)) env in - let build_premise cons_sum = - lift_constructor 1 cons_sum |> split_case fix_env !evm fix_term |> - premise_of_case fix_env ind_fam |> drop_rel - in - get_constructors env ind_fam |> Array.map build_premise - in - mkApp (elim_head, premises) - -(* - * Translate a fixed-point function into an elimination form. - * - * This function works by transforming the fixed point to use simple recursion - * (i.e., to quantify the inductive type like a dependent eliminator), calling - * desugar_recusion, and then wrapping the translated elimination form to conform - * to the original fixed point's type. - * - * Note that the resulting term will not satisfy definitional equality with the - * original term but should satisfy most (all?) definitional equalities when - * applied to all indices and a head-canonical discriminee. Still, this could - * impact the well-typedness of inductive proof terms, particularly when - * rewriting the unrolled recursive function by an inductive hypothesis. We will - * know more after testing compositional translation of a complete module, which - * will avoid incidental mixtures of the old version (by named constant) and the - * new version (by expanded definition). (Such incidental mixtures arise, for - * example, in some of the List module's proofs regarding the In predicate.) - *) -let desugar_fixpoint env evm fix_pos fix_name fix_type fix_term = - let nb = fix_pos + 1 in (* number of bindings guarding recursion *) - (* Pull off bindings through the parameter guarding structural recursion *) - let fix_ctxt, fix_type = decompose_prod_n_zeta nb fix_type in - let _, fix_term = decompose_lam_n_zeta nb fix_term in - (* Gather information on the inductive type for recursion/elimination *) - let ind_name, ind_type = Rel.lookup 1 fix_ctxt |> pair rel_name rel_type in - let pind, params, indices = decompose_ind (lift_rel ind_type) in - let ind_fam = make_ind_family (pind, params) in - let env = Environ.push_rel_context fix_ctxt env in (* for eventual wrapper *) - let rec_ctxt, rec_args = (* quantify the inductive type like an eliminator *) - let ind_ctxt = build_inductive_context env ind_fam ind_name in - let fun_ctxt = build_recursive_context fix_ctxt params indices in - fun_ctxt @ ind_ctxt, - Array.of_list (indices @ (mkRel 1) :: Rel.to_extended_list mkRel 0 fun_ctxt) - in - let nb' = Rel.length rec_ctxt in - let k = Debruijn.unshift_i_by nb nb' in (* always more bindings than before *) - let rec_type = - fix_type |> lift_rels ~skip:nb nb |> (* for external wrapper *) - lift_rels ~skip:nb k |> smash_prod_assum rec_ctxt - in - let rec_term = - let nb_rec = Debruijn.shift_i nb in (* include self reference *) - let rec_env = Environ.push_rel (rel_assum (fix_name, rec_type)) env in - let rec_ctxt = Termops.lift_rel_context 1 rec_ctxt in - let fix_self = (* wrapper to adjust arguments for a recursive call *) - recompose_lam_assum - (Termops.lift_rel_context nb_rec fix_ctxt) - (mkApp (mkRel nb_rec, rec_args)) - in - fix_term |> lift_rels ~skip:nb_rec nb |> (* for external wrapper *) - lift_rels ~skip:nb k |> smash_lam_assum rec_ctxt |> - lift_rel ~skip:1 |> Vars.subst1 fix_self |> Reduction.nf_betaiota rec_env - in - (* Desugar the simple recursive function into an elimination form *) - let rec_elim = desugar_recursion env evm ind_fam fix_name rec_type rec_term in - (* Wrap the elimination form to reorder initial arguments *) - recompose_lam_assum fix_ctxt (mkApp (rec_elim, rec_args)) - -(* - * Given the components of a match expression, build an equivalent elimination - * expression. The resulting term will not use any recurrence (i.e., inductive - * hypothesis) bound in the minor elimination premises (i.e., case functions), - * since the original term was non-recursive. - * - * Note that the resulting term may not satisfy definitional equality with the - * original term, as Coq lacks eta-conversion between a non-recursive function - * and its fixed point (i.e., f =\= fix[_.f]). Definitional equality should hold - * (at least) when the discriminee term is head-canonical. - *) -let desugar_match env evm info pred discr cases = - let typ = lambda_to_prod pred in - let pind, params, indices = decompose_indvect (e_infer_type env evm discr) in - let ind_fam = make_ind_family (pind, Array.to_list params) in - let elim_head = configure_eliminator env evm ind_fam typ in - let premises = - let fix_env = Environ.push_rel (rel_assum (Name.Anonymous, typ)) env in - let cases = Array.map lift_rel cases in - let build_premise cons_case cons_sum = - lift_constructor 1 cons_sum |> expand_case fix_env !evm cons_case |> - premise_of_case fix_env ind_fam |> drop_rel - in - get_constructors fix_env ind_fam |> Array.map2 build_premise cases - in - mkApp (elim_head, Array.concat [premises; indices; [|discr|]]) - -(* - * Translate the given term into an equivalent, bisimulative (i.e., homomorpic - * reduction behavior) version using eliminators instead of match or fix - * expressions. - * - * Mutual recursion, co-recursion, and universe polymorphism are not supported. - *) -let desugar_constr env evm term = - let rec aux env term = - match Constr.kind term with - | Lambda (name, param, body) -> - let param' = aux env param in - let body' = aux (push_local (name, param') env) body in - mkLambda (name, param', body') - | Prod (name, param, body) -> - let param' = aux env param in - let body' = aux (push_local (name, param') env) body in - mkProd (name, param', body') - | LetIn (name, local, annot, body) -> - let local' = aux env local in - let annot' = aux env annot in - let body' = aux (push_let_in (name, local', annot') env) body in - mkLetIn (name, local', annot', body') - | Fix (([|fix_pos|], 0), ([|fix_name|], [|fix_type|], [|fix_term|])) -> - desugar_fixpoint env evm fix_pos fix_name fix_type fix_term |> aux env - | Fix _ -> - user_err ~hdr:"desugar" (Pp.str "mutual recursion not supported") - | CoFix _ -> - user_err ~hdr:"desugar" (Pp.str "co-recursion not supported") - | Case (info, pred, discr, cases) -> - desugar_match env evm info pred discr cases |> aux env - | _ -> - Constr.map (aux env) term - in - let term' = aux env term in - ignore (e_infer_type env evm term'); (* to infer universe constraints *) - term' diff --git a/plugin/src/core/procedures/desugar.mli b/plugin/src/core/procedures/desugar.mli deleted file mode 100644 index 8ea3fa7..0000000 --- a/plugin/src/core/procedures/desugar.mli +++ /dev/null @@ -1,11 +0,0 @@ -open Environ -open Constr - -(* - * Translate the given term into an equivalent, bisimulative (i.e., homomorpic - * reduction behavior) version using eliminators instead of match or fix - * expressions. - * - * Mutual recursion and co-recursion are not supported. - *) -val desugar_constr : env -> Evd.evar_map ref -> constr -> constr (* Coqterms.constr_transformer *) diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index b87b9b3..f2125bd 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -23,7 +23,6 @@ open Cutlemma open Kindofchange open Changedetectors open Stdarg -open Desugar open Utilities open Zooming @@ -132,46 +131,6 @@ let patch n try_invert a search = else () -(* - * Translate each fix or match subterm into an equivalent application of an - * eliminator, defining the new term with the given name. - * - * Mutual fix or cofix subterms are not supported. - * (By Nate Yazdani, from DEVOID) - *) -let do_desugar_constant ident const_ref = - ignore - begin - qualid_of_reference const_ref |> Nametab.locate_constant |> - Global.lookup_constant |> transform_constant ident desugar_constr - end - -(* - * Translate fix and match expressions into eliminations, as in - * do_desugar_constant, compositionally throughout a whole module. - * - * The optional argument is a list of constants outside the module to include - * in the translated module as if they were components in the input module. - * (By Nate Yazdani, from DEVOID) - *) -let do_desugar_module ?(incl=[]) ident mod_ref = - let open Util in - let consts = List.map (qualid_of_reference %> Nametab.locate_constant) incl in - let include_constant subst const = - let ident = Label.to_id (Constant.label const) in - let tr_constr env evm = subst_globals subst %> desugar_constr env evm in - let const' = - Global.lookup_constant const |> transform_constant ident tr_constr - in - Globmap.add (ConstRef const) (ConstRef const') subst - in - let init () = List.fold_left include_constant Globmap.empty consts in - ignore - begin - qualid_of_reference mod_ref |> Nametab.locate_module |> - Global.lookup_module |> transform_module_structure ~init ident desugar_constr - end - (* --- Commands --- *) (* @@ -314,13 +273,3 @@ VERNAC COMMAND EXTEND FactorCandidate CLASSIFIED AS SIDEFF | [ "Factor" constr(trm) "using" "prefix" ident(n) ] -> [ factor n trm ] END - -(* Desugar any/all fix/match subterms into eliminator applications *) -VERNAC COMMAND EXTEND TranslateMatch CLASSIFIED AS SIDEFF -| [ "Preprocess" reference(const_ref) "as" ident(id) ] -> - [ do_desugar_constant id const_ref ] -| [ "Preprocess" "Module" reference(mod_ref) "as" ident(id) ] -> - [ do_desugar_module id mod_ref ] -| [ "Preprocess" "Module" reference(mod_ref) "as" ident(id) "{" "include" ne_reference_list_sep(incl_refs, ",") "}" ] -> - [ do_desugar_module ~incl:incl_refs id mod_ref ] -END diff --git a/plugin/theories/Patch.v b/plugin/theories/Patch.v index 8b605c3..1a5c5ec 100644 --- a/plugin/theories/Patch.v +++ b/plugin/theories/Patch.v @@ -1 +1,3 @@ Declare ML Module "patch". + +Require Export Fixtranslation.Fixtoelim. \ No newline at end of file From bdcfa47d3b7d909d4aab0b75948bf3b0abfe9233 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 25 Jul 2019 12:26:05 -0700 Subject: [PATCH 030/154] Ignore .merlin --- .gitignore | 1 + plugin/.merlin | 6 ------ 2 files changed, 1 insertion(+), 6 deletions(-) delete mode 100644 plugin/.merlin diff --git a/.gitignore b/.gitignore index ec833c5..ddd24d0 100644 --- a/.gitignore +++ b/.gitignore @@ -22,3 +22,4 @@ plugin/*.cmi *.a *.cmxa *.conf +.merlin diff --git a/plugin/.merlin b/plugin/.merlin deleted file mode 100644 index b75918a..0000000 --- a/plugin/.merlin +++ /dev/null @@ -1,6 +0,0 @@ -FLG -rectypes -thread -w @1..50@59-4-44 -safe-string - -S src/** -B src/** - -PKG threads threads.posix coq.intf coq.ltac From abbbe20939c79b94db469cf2c10f8f459aed3607 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Sun, 28 Jul 2019 16:08:25 -0700 Subject: [PATCH 031/154] Merge DEVOID (fixes #7) (fixes #30) --- .gitmodules | 4 ++++ plugin/build.sh | 6 +++++- plugin/deps/ornamental-search | 1 + plugin/theories/Patch.v | 3 ++- 4 files changed, 12 insertions(+), 2 deletions(-) create mode 160000 plugin/deps/ornamental-search diff --git a/.gitmodules b/.gitmodules index e56dc79..1c19b69 100644 --- a/.gitmodules +++ b/.gitmodules @@ -4,3 +4,7 @@ [submodule "plugin/deps/fix-to-elim"] path = plugin/deps/fix-to-elim url = https://github.com/uwplse/fix-to-elim.git +[submodule "plugin/deps/ornamental-search"] + path = plugin/deps/ornamental-search + url = https://github.com/uwplse/ornamental-search.git + branch = 0.1 diff --git a/plugin/build.sh b/plugin/build.sh index c2e2a12..43134e4 100755 --- a/plugin/build.sh +++ b/plugin/build.sh @@ -1,10 +1,14 @@ #!/usr/bin/env bash git submodule init git submodule update -echo "building dependencies" +echo "building PUMPKIN PATCH dependencies" cd deps/fix-to-elim/plugin ./build.sh cd ../../.. +cd deps/ornamental-search/plugin +./build.sh +cd ../../.. +echo "done building PUMPKIN PATCH dependencies" echo "building PUMPKIN PATCH" coq_makefile -f _CoqProject -o Makefile make clean && make && make install diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search new file mode 160000 index 0000000..7e6e88c --- /dev/null +++ b/plugin/deps/ornamental-search @@ -0,0 +1 @@ +Subproject commit 7e6e88cae73e5d6f8e6256671e1ca64b5bc66682 diff --git a/plugin/theories/Patch.v b/plugin/theories/Patch.v index 1a5c5ec..02d0ffc 100644 --- a/plugin/theories/Patch.v +++ b/plugin/theories/Patch.v @@ -1,3 +1,4 @@ Declare ML Module "patch". -Require Export Fixtranslation.Fixtoelim. \ No newline at end of file +Require Export Fixtranslation.Fixtoelim. +Require Export Ornamental.Ornaments. From bd2bc00e3541f8a480a974796ab1598e05f279eb Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 31 Jul 2019 11:59:38 -0700 Subject: [PATCH 032/154] update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 7fa57cf..05bd0cb 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 7fa57cfd01331251f46638ca5fcedce899251316 +Subproject commit 05bd0cbe0f4793e54a1b8ddffe61f58ba77b0731 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 7e6e88c..d17a518 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 7e6e88cae73e5d6f8e6256671e1ca64b5bc66682 +Subproject commit d17a518a8d3bd533b92575e20afc731166cf8c84 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index de8dcc7..e005a06 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit de8dcc7e93ea3198fde8cf976247579983d1587f +Subproject commit e005a067f9093a0ed297c4187ec017b0bd14b2bc From c16ea5e93429d20308f9921d86aeecfcb32b36df Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 31 Jul 2019 12:19:30 -0700 Subject: [PATCH 033/154] Update code to match updated library --- plugin/_CoqProject | 11 +++++++++++ plugin/src/compilation/evaluation.ml | 1 + plugin/src/compilation/expansion.ml | 2 ++ plugin/src/compilation/proofdiff.ml | 2 ++ plugin/src/configuration/searchopts.ml | 2 ++ plugin/src/core/components/abstraction/abstracters.ml | 1 + plugin/src/core/components/abstraction/abstraction.ml | 1 + .../core/components/differencing/appdifferencers.ml | 1 + .../core/components/differencing/changedetectors.ml | 1 + .../core/components/differencing/fixdifferencers.ml | 1 + .../core/components/differencing/proofdifferencers.ml | 1 + plugin/src/core/components/factoring/factoring.ml | 2 ++ plugin/src/core/components/inversion/inverting.ml | 2 ++ plugin/src/core/procedures/theorem.ml | 1 + plugin/src/patch.mlpack | 4 ++++ plugin/src/representation/assumptions.ml | 2 ++ plugin/src/representation/categories/proofcat.ml | 1 + plugin/src/representation/cutlemma.ml | 2 ++ 18 files changed, 38 insertions(+) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 647cb83..bf8483e 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,5 +1,8 @@ -I src/coq-plugin-lib/src/utilities -I src/coq-plugin-lib/src/coq +-I src/coq-plugin-lib/src/coq/terms +-I src/coq-plugin-lib/src/coq/types +-I src/coq-plugin-lib/src/coq/induction -I src/representation -I src/representation/categories -I src/configuration @@ -28,6 +31,14 @@ src/coq-plugin-lib/src/coq/hofs.mli src/coq-plugin-lib/src/coq/hofs.ml src/coq-plugin-lib/src/coq/zooming.mli src/coq-plugin-lib/src/coq/zooming.ml +src/coq-plugin-lib/src/coq/terms/termdiffutils.mli +src/coq-plugin-lib/src/coq/terms/termdiffutils.ml +src/coq-plugin-lib/src/coq/types/typeutils.mli +src/coq-plugin-lib/src/coq/types/typeutils.ml +src/coq-plugin-lib/src/coq/types/typediffutils.mli +src/coq-plugin-lib/src/coq/types/typediffutils.ml +src/coq-plugin-lib/src/coq/induction/indutils.mli +src/coq-plugin-lib/src/coq/induction/indutils.ml src/coq-plugin-lib/src/coq/substitution.mli src/coq-plugin-lib/src/coq/substitution.ml src/coq-plugin-lib/src/coq/filters.mli diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 5bb5599..4ce1d69 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -10,6 +10,7 @@ open Utilities open Names open Debruijn open Declarations +open Indutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index a58a8c7..59926ec 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -11,6 +11,8 @@ open Evaluation open Utilities open Debruijn open Declarations +open Termdiffutils +open Indutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 1df25ac..7a16465 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -13,6 +13,8 @@ open Reducers open Declarations open Utilities open Merging +open Termdiffutils +open Indutils (* * Note: Evar discipline here is not good yet, but will change diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index dff8bcf..0d1fbd9 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -12,6 +12,8 @@ open Assumptions open Kindofchange open Cutlemma open Catzooming +open Termdiffutils +open Indutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 0b13044..cb43da4 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -9,6 +9,7 @@ open Substitution open Reducers open Filters open Candidates +open Typediffutils type abstraction_dimension = Arguments | Property type abstracter = env -> evar_map -> types -> types -> candidates -> candidates diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 6a510f4..715f396 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -17,6 +17,7 @@ open Searchopts open Cutlemma open Filters open Zooming +open Termdiffutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 17cc203..1ee372a 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -17,6 +17,7 @@ open Zooming open Catzooming open Debruijn open Filters +open Termdiffutils (* * Given a search function and a difference between terms, diff --git a/plugin/src/core/components/differencing/changedetectors.ml b/plugin/src/core/components/differencing/changedetectors.ml index 046c774..40edfc0 100644 --- a/plugin/src/core/components/differencing/changedetectors.ml +++ b/plugin/src/core/components/differencing/changedetectors.ml @@ -11,6 +11,7 @@ open Reducers open Assumptions open Utilities open Zooming +open Termdiffutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index f19b41a..ace1efd 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -12,6 +12,7 @@ open Debruijn open Higherdifferencers open Evd open Zooming +open Termdiffutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index 9b635fa..84cb6f6 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -15,6 +15,7 @@ open Reducers open Kindofchange open Names open Zooming +open Termdiffutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index 1102646..07d3484 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -9,6 +9,8 @@ open Specialization open Names open Utilities open Debruijn +open Termdiffutils +open Typeutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 5b3ba2b..e6caddb 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -12,6 +12,8 @@ open Assumptions open Hofs open Filters open Factoring +open Termdiffutils +open Typeutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 3d88748..677b415 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -9,6 +9,7 @@ open Reducers open Specialization open Evd open Zooming +open Termdiffutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index d9c23a1..faadd67 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -5,6 +5,10 @@ Printing Debruijn Hofs Zooming +Termdiffutils +Typeutils +Typediffutils +Indutils Substitution Filters Reducers diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 3f59d0d..c90bdaa 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -8,6 +8,8 @@ open Debruijn open Coqterms open Hofs open Printing +open Termdiffutils +open Typediffutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index d0fc50d..53205c1 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -9,6 +9,7 @@ open Coqterms open Assumptions open Utilities open Merging +open Termdiffutils (* * Note: Evar discipline is currently very bad here. But, we will eventually diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index baab5dd..a06141c 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -7,6 +7,8 @@ open Reducers open Coqterms open Debruijn open Utilities +open Termdiffutils +open Typeutils module CRD = Context.Rel.Declaration From a96a690e9d1dac511c9c869c910fece7c6891341 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 31 Jul 2019 15:52:56 -0700 Subject: [PATCH 034/154] update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 05bd0cb..ed394ac 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 05bd0cbe0f4793e54a1b8ddffe61f58ba77b0731 +Subproject commit ed394ac5525379bec14d39b357efb160318a988f diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index d17a518..ad6a6b2 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit d17a518a8d3bd533b92575e20afc731166cf8c84 +Subproject commit ad6a6b27eab4a4ed3e6f75e80812c1ff5f152482 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index e005a06..de8ee61 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit e005a067f9093a0ed297c4187ec017b0bd14b2bc +Subproject commit de8ee6133cf3fb77fec05a3bee938e5d1db1cbe3 From dcd3b6bf999a8ce8a75c5737261c04effa1798cd Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 31 Jul 2019 16:02:53 -0700 Subject: [PATCH 035/154] Update sources to match dependencies --- plugin/_CoqProject | 22 +++++++++---------- plugin/src/compilation/expansion.ml | 2 +- plugin/src/compilation/proofdiff.ml | 2 +- plugin/src/configuration/searchopts.ml | 2 +- .../components/abstraction/abstracters.ml | 2 +- .../components/abstraction/abstraction.ml | 2 +- .../differencing/appdifferencers.ml | 2 +- .../differencing/changedetectors.ml | 2 +- .../differencing/fixdifferencers.ml | 2 +- .../differencing/proofdifferencers.ml | 2 +- .../core/components/factoring/factoring.ml | 2 +- .../core/components/inversion/inverting.ml | 2 +- plugin/src/core/procedures/theorem.ml | 2 +- plugin/src/patch.mlpack | 8 ++++--- plugin/src/representation/assumptions.ml | 3 +-- .../src/representation/categories/proofcat.ml | 2 +- plugin/src/representation/cutlemma.ml | 2 +- 17 files changed, 31 insertions(+), 30 deletions(-) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index bf8483e..3315a3d 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,8 +1,6 @@ -I src/coq-plugin-lib/src/utilities -I src/coq-plugin-lib/src/coq --I src/coq-plugin-lib/src/coq/terms --I src/coq-plugin-lib/src/coq/types --I src/coq-plugin-lib/src/coq/induction +-I src/coq-plugin-lib/src/components/differencing -I src/representation -I src/representation/categories -I src/configuration @@ -29,16 +27,18 @@ src/coq-plugin-lib/src/coq/debruijn.mli src/coq-plugin-lib/src/coq/debruijn.ml src/coq-plugin-lib/src/coq/hofs.mli src/coq-plugin-lib/src/coq/hofs.ml +src/coq-plugin-lib/src/coq/inference.ml +src/coq-plugin-lib/src/coq/inference.mli +src/coq-plugin-lib/src/coq/convertibility.ml +src/coq-plugin-lib/src/coq/convertibility.mli +src/coq-plugin-lib/src/coq/typeutils.ml +src/coq-plugin-lib/src/coq/typeutils.mli +src/coq-plugin-lib/src/components/differencing/diffutils.ml +src/coq-plugin-lib/src/components/differencing/diffutils.mli +src/coq-plugin-lib/src/coq/indutils.ml +src/coq-plugin-lib/src/coq/indutils.mli src/coq-plugin-lib/src/coq/zooming.mli src/coq-plugin-lib/src/coq/zooming.ml -src/coq-plugin-lib/src/coq/terms/termdiffutils.mli -src/coq-plugin-lib/src/coq/terms/termdiffutils.ml -src/coq-plugin-lib/src/coq/types/typeutils.mli -src/coq-plugin-lib/src/coq/types/typeutils.ml -src/coq-plugin-lib/src/coq/types/typediffutils.mli -src/coq-plugin-lib/src/coq/types/typediffutils.ml -src/coq-plugin-lib/src/coq/induction/indutils.mli -src/coq-plugin-lib/src/coq/induction/indutils.ml src/coq-plugin-lib/src/coq/substitution.mli src/coq-plugin-lib/src/coq/substitution.ml src/coq-plugin-lib/src/coq/filters.mli diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 59926ec..bc278b1 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -11,7 +11,7 @@ open Evaluation open Utilities open Debruijn open Declarations -open Termdiffutils +open Convertibility open Indutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 7a16465..450ea0c 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -13,7 +13,7 @@ open Reducers open Declarations open Utilities open Merging -open Termdiffutils +open Convertibility open Indutils (* diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index 0d1fbd9..bf2acb0 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -12,7 +12,7 @@ open Assumptions open Kindofchange open Cutlemma open Catzooming -open Termdiffutils +open Convertibility open Indutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index cb43da4..8032717 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -9,7 +9,7 @@ open Substitution open Reducers open Filters open Candidates -open Typediffutils +open Convertibility type abstraction_dimension = Arguments | Property type abstracter = env -> evar_map -> types -> types -> candidates -> candidates diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 715f396..fe9efc7 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -17,7 +17,7 @@ open Searchopts open Cutlemma open Filters open Zooming -open Termdiffutils +open Convertibility module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 1ee372a..3c839fb 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -17,7 +17,7 @@ open Zooming open Catzooming open Debruijn open Filters -open Termdiffutils +open Convertibility (* * Given a search function and a difference between terms, diff --git a/plugin/src/core/components/differencing/changedetectors.ml b/plugin/src/core/components/differencing/changedetectors.ml index 40edfc0..215ed4a 100644 --- a/plugin/src/core/components/differencing/changedetectors.ml +++ b/plugin/src/core/components/differencing/changedetectors.ml @@ -11,7 +11,7 @@ open Reducers open Assumptions open Utilities open Zooming -open Termdiffutils +open Convertibility module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index ace1efd..438de49 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -12,7 +12,7 @@ open Debruijn open Higherdifferencers open Evd open Zooming -open Termdiffutils +open Convertibility module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index 84cb6f6..a31b336 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -15,7 +15,7 @@ open Reducers open Kindofchange open Names open Zooming -open Termdiffutils +open Convertibility module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index 07d3484..12f8591 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -9,7 +9,7 @@ open Specialization open Names open Utilities open Debruijn -open Termdiffutils +open Convertibility open Typeutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index e6caddb..57139d6 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -12,7 +12,7 @@ open Assumptions open Hofs open Filters open Factoring -open Termdiffutils +open Convertibility open Typeutils module CRD = Context.Rel.Declaration diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 677b415..9a2161b 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -9,7 +9,7 @@ open Reducers open Specialization open Evd open Zooming -open Termdiffutils +open Convertibility module CRD = Context.Rel.Declaration diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index faadd67..c3bbf98 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -4,10 +4,12 @@ Coqterms Printing Debruijn Hofs -Zooming -Termdiffutils +Inference +Convertibility Typeutils -Typediffutils +Diffutils +Indutils +Zooming Indutils Substitution Filters diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index c90bdaa..5370854 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -8,8 +8,7 @@ open Debruijn open Coqterms open Hofs open Printing -open Termdiffutils -open Typediffutils +open Convertibility module CRD = Context.Rel.Declaration diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index 53205c1..9e767d3 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -9,7 +9,7 @@ open Coqterms open Assumptions open Utilities open Merging -open Termdiffutils +open Convertibility (* * Note: Evar discipline is currently very bad here. But, we will eventually diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index a06141c..1af912d 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -7,7 +7,7 @@ open Reducers open Coqterms open Debruijn open Utilities -open Termdiffutils +open Convertibility open Typeutils module CRD = Context.Rel.Declaration From 4535723d66818e240ff48d85a06f553e9c134ea3 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 5 Aug 2019 16:01:06 -0700 Subject: [PATCH 036/154] Update dependencies (will break build temporarily) --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index ed394ac..fed9cd2 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit ed394ac5525379bec14d39b357efb160318a988f +Subproject commit fed9cd2bdff733108332769d596d913c7ef733a0 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index ad6a6b2..b12674b 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit ad6a6b27eab4a4ed3e6f75e80812c1ff5f152482 +Subproject commit b12674b4b2ea98866d3f0513f7fd220893d8dfff diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index de8ee61..bea3af7 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit de8ee6133cf3fb77fec05a3bee938e5d1db1cbe3 +Subproject commit bea3af7a8b440abfe025649c74ba9912de275bf3 From 4f8188d8f4f0dae9f59049d16c282b9db677d9fa Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 5 Aug 2019 16:34:16 -0700 Subject: [PATCH 037/154] get plugin to build again --- plugin/_CoqProject | 85 +++++++++++++------ .../src/compilation/categories/catzooming.ml | 1 - plugin/src/compilation/evaluation.ml | 4 +- plugin/src/compilation/expansion.ml | 4 +- plugin/src/compilation/proofdiff.ml | 1 - plugin/src/configuration/searchopts.ml | 4 +- .../components/abstraction/abstracters.ml | 1 - .../components/abstraction/abstraction.ml | 6 +- .../abstraction/abstractionconfig.ml | 5 +- .../differencing/appdifferencers.ml | 1 - .../differencing/changedetectors.ml | 4 +- .../components/differencing/differencing.ml | 1 - .../differencing/fixdifferencers.ml | 5 +- .../differencing/proofdifferencers.ml | 5 +- .../core/components/factoring/factoring.ml | 6 +- .../core/components/inversion/inverting.ml | 7 +- .../specialization/specialization.ml | 5 +- plugin/src/core/procedures/theorem.ml | 4 +- plugin/src/patch.mlpack | 33 ++++--- plugin/src/patcher.ml4 | 3 +- plugin/src/representation/assumptions.ml | 5 +- .../src/representation/categories/proofcat.ml | 1 - plugin/src/representation/cutlemma.ml | 11 ++- plugin/src/representation/merging.ml | 6 +- plugin/src/representation/merging.mli | 2 +- 25 files changed, 114 insertions(+), 96 deletions(-) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 3315a3d..32b0f35 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -1,6 +1,14 @@ -I src/coq-plugin-lib/src/utilities -I src/coq-plugin-lib/src/coq --I src/coq-plugin-lib/src/components/differencing +-I src/coq-plugin-lib/src/coq/termutils +-I src/coq-plugin-lib/src/coq/constants +-I src/coq-plugin-lib/src/coq/logicutils +-I src/coq-plugin-lib/src/coq/logicutils/contexts +-I src/coq-plugin-lib/src/coq/logicutils/typesandequality +-I src/coq-plugin-lib/src/coq/logicutils/hofs +-I src/coq-plugin-lib/src/coq/logicutils/inductive +-I src/coq-plugin-lib/src/coq/devutils +-I src/coq-plugin-lib/src/coq/representationutils -I src/representation -I src/representation/categories -I src/configuration @@ -16,35 +24,56 @@ -R src Patcher -Q theories Patcher -src/coq-plugin-lib/src/utilities/utilities.mli src/coq-plugin-lib/src/utilities/utilities.ml +src/coq-plugin-lib/src/utilities/utilities.mli + +src/coq-plugin-lib/src/coq/termutils/apputils.mli +src/coq-plugin-lib/src/coq/termutils/apputils.ml +src/coq-plugin-lib/src/coq/termutils/funutils.mli +src/coq-plugin-lib/src/coq/termutils/funutils.ml + +src/coq-plugin-lib/src/coq/constants/equtils.mli +src/coq-plugin-lib/src/coq/constants/equtils.ml +src/coq-plugin-lib/src/coq/constants/sigmautils.mli +src/coq-plugin-lib/src/coq/constants/sigmautils.ml +src/coq-plugin-lib/src/coq/constants/idutils.mli +src/coq-plugin-lib/src/coq/constants/idutils.ml + +src/coq-plugin-lib/src/coq/representationutils/defutils.mli +src/coq-plugin-lib/src/coq/representationutils/defutils.ml + +src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.mli +src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.ml +src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.mli +src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.ml + +src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.mli +src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.ml +src/coq-plugin-lib/src/coq/logicutils/contexts/contextutils.mli +src/coq-plugin-lib/src/coq/logicutils/contexts/contextutils.ml + +src/coq-plugin-lib/src/coq/logicutils/hofs/hofs.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/hofs.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/hofimpls.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/hofimpls.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/debruijn.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/debruijn.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/substitution.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/substitution.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/reducers.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/reducers.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/typehofs.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/typehofs.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/zooming.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/zooming.ml +src/coq-plugin-lib/src/coq/logicutils/hofs/filters.mli +src/coq-plugin-lib/src/coq/logicutils/hofs/filters.ml + +src/coq-plugin-lib/src/coq/logicutils/inductive/indutils.mli +src/coq-plugin-lib/src/coq/logicutils/inductive/indutils.ml -src/coq-plugin-lib/src/coq/coqterms.mli -src/coq-plugin-lib/src/coq/coqterms.ml -src/coq-plugin-lib/src/coq/printing.mli -src/coq-plugin-lib/src/coq/printing.ml -src/coq-plugin-lib/src/coq/debruijn.mli -src/coq-plugin-lib/src/coq/debruijn.ml -src/coq-plugin-lib/src/coq/hofs.mli -src/coq-plugin-lib/src/coq/hofs.ml -src/coq-plugin-lib/src/coq/inference.ml -src/coq-plugin-lib/src/coq/inference.mli -src/coq-plugin-lib/src/coq/convertibility.ml -src/coq-plugin-lib/src/coq/convertibility.mli -src/coq-plugin-lib/src/coq/typeutils.ml -src/coq-plugin-lib/src/coq/typeutils.mli -src/coq-plugin-lib/src/components/differencing/diffutils.ml -src/coq-plugin-lib/src/components/differencing/diffutils.mli -src/coq-plugin-lib/src/coq/indutils.ml -src/coq-plugin-lib/src/coq/indutils.mli -src/coq-plugin-lib/src/coq/zooming.mli -src/coq-plugin-lib/src/coq/zooming.ml -src/coq-plugin-lib/src/coq/substitution.mli -src/coq-plugin-lib/src/coq/substitution.ml -src/coq-plugin-lib/src/coq/filters.mli -src/coq-plugin-lib/src/coq/filters.ml -src/coq-plugin-lib/src/coq/reducers.mli -src/coq-plugin-lib/src/coq/reducers.ml +src/coq-plugin-lib/src/coq/devutils/printing.mli +src/coq-plugin-lib/src/coq/devutils/printing.ml src/representation/candidates.mli src/representation/candidates.ml diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index 38ce13c..83381c5 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -1,6 +1,5 @@ open Proofcat open Environ -open Coqterms open Proofdiff open Proofcatterms open Expansion diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 4ce1d69..1f2b239 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -5,14 +5,12 @@ open Environ open Evd open Proofcat open Proofcatterms -open Coqterms open Utilities open Names open Debruijn open Declarations open Indutils - -module CRD = Context.Rel.Declaration +open Contextutils (* --- TODO for refactoring without breaking things --- *) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index bc278b1..8f414f0 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -4,7 +4,6 @@ open Names open Environ open Evd open Constr -open Coqterms open Proofcat open Proofcatterms open Evaluation @@ -13,8 +12,7 @@ open Debruijn open Declarations open Convertibility open Indutils - -module CRD = Context.Rel.Declaration +open Contextutils (* --- TODO for refactoring without breaking things --- *) diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 450ea0c..03a46f2 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -6,7 +6,6 @@ open Evd open Proofcat open Assumptions open Expansion -open Coqterms open Evaluation open Proofcatterms open Reducers diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index bf2acb0..61e43d9 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -2,7 +2,6 @@ open Constr open Environ -open Coqterms open Proofcat open Proofcatterms open Debruijn @@ -14,8 +13,7 @@ open Cutlemma open Catzooming open Convertibility open Indutils - -module CRD = Context.Rel.Declaration +open Contextutils (* * Note: Evar discipline is not good here yet, but will change when diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 8032717..c824b1c 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -3,7 +3,6 @@ open Constr open Environ open Evd -open Coqterms open Utilities open Substitution open Reducers diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index fe9efc7..9029df8 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -7,7 +7,6 @@ open Environ open Evd open Constr open Debruijn -open Coqterms open Utilities open Reducers open Specialization @@ -18,8 +17,9 @@ open Cutlemma open Filters open Zooming open Convertibility - -module CRD = Context.Rel.Declaration +open Contextutils +open Merging +open Apputils (* --- TODO for refactoring without breaking things --- *) diff --git a/plugin/src/core/components/abstraction/abstractionconfig.ml b/plugin/src/core/components/abstraction/abstractionconfig.ml index ad12271..0783cd1 100644 --- a/plugin/src/core/components/abstraction/abstractionconfig.ml +++ b/plugin/src/core/components/abstraction/abstractionconfig.ml @@ -3,13 +3,12 @@ open Evd open Constr open Abstracters open Candidates -open Coqterms open Debruijn open Utilities open Proofdiff open Cutlemma - -module CRD = Context.Rel.Declaration +open Contextutils +open Envutils (* --- TODO for refactoring without breaking things --- *) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 3c839fb..2abc09c 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -7,7 +7,6 @@ open Proofdiff open Candidates open Searchopts open Evd -open Coqterms open Proofdifferencers open Higherdifferencers open Assumptions diff --git a/plugin/src/core/components/differencing/changedetectors.ml b/plugin/src/core/components/differencing/changedetectors.ml index 215ed4a..d00ac19 100644 --- a/plugin/src/core/components/differencing/changedetectors.ml +++ b/plugin/src/core/components/differencing/changedetectors.ml @@ -2,7 +2,6 @@ open Constr open Environ -open Coqterms open Proofdiff open Proofcatterms open Cutlemma @@ -12,8 +11,7 @@ open Assumptions open Utilities open Zooming open Convertibility - -module CRD = Context.Rel.Declaration +open Contextutils (* * If the kind of change is a change in conclusion, then diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index b47885b..fa8395c 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -2,7 +2,6 @@ open Searchopts open Proofdiff -open Coqterms open Reducers open Candidates open Kindofchange diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index 438de49..0d29bd8 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -3,7 +3,6 @@ open Utilities open Constr open Environ -open Coqterms open Proofdiff open Candidates open Reducers @@ -13,8 +12,8 @@ open Higherdifferencers open Evd open Zooming open Convertibility - -module CRD = Context.Rel.Declaration +open Contextutils +open Envutils (* --- Cases --- *) diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index a31b336..a4f3127 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -2,7 +2,6 @@ open Proofcatterms open Constr -open Coqterms open Environ open Searchopts open Substitution @@ -16,8 +15,8 @@ open Kindofchange open Names open Zooming open Convertibility - -module CRD = Context.Rel.Declaration +open Contextutils +open Idutils (* --- TODO for refactoring without breaking things --- *) diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index 12f8591..c628129 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -3,16 +3,14 @@ open Constr open Environ open Evd -open Coqterms open Reducers open Specialization open Names open Utilities open Debruijn open Convertibility -open Typeutils - -module CRD = Context.Rel.Declaration +open Reducers +open Contextutils type factors = (env * types) list diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 57139d6..2058613 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -3,7 +3,6 @@ open Constr open Environ open Evd -open Coqterms open Utilities open Debruijn open Reducers @@ -13,9 +12,9 @@ open Hofs open Filters open Factoring open Convertibility -open Typeutils - -module CRD = Context.Rel.Declaration +open Reducers +open Contextutils +open Equtils type inverter = evar_map -> (env * types) -> (env * types) option diff --git a/plugin/src/core/components/specialization/specialization.ml b/plugin/src/core/components/specialization/specialization.ml index 25dac02..d4ad319 100644 --- a/plugin/src/core/components/specialization/specialization.ml +++ b/plugin/src/core/components/specialization/specialization.ml @@ -12,11 +12,10 @@ open Environ open Evd open Constr -open Coqterms open Reducers open Utilities - -module CRD = Context.Rel.Declaration +open Contextutils +open Envutils type specializer = env -> evar_map -> types -> types array -> types diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 9a2161b..7aa93bc 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -2,7 +2,6 @@ open Constr open Environ -open Coqterms open Substitution open Debruijn open Reducers @@ -10,8 +9,7 @@ open Specialization open Evd open Zooming open Convertibility - -module CRD = Context.Rel.Declaration +open Contextutils (* --- TODO for refactoring without breaking things --- *) diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index c3bbf98..33828a7 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -1,19 +1,32 @@ Utilities -Coqterms -Printing -Debruijn -Hofs +Apputils +Funutils + +Equtils +Sigmautils +Idutils + +Defutils + Inference Convertibility -Typeutils -Diffutils -Indutils -Zooming -Indutils + +Envutils +Contextutils + +Hofs +Debruijn +Hofimpls Substitution -Filters Reducers +Typehofs +Zooming +Filters + +Indutils + +Printing Candidates Assumptions diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index f2125bd..82c07e5 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -4,7 +4,6 @@ DECLARE PLUGIN "patch" open Constr open Names open Environ -open Coqterms open Assumptions open Evaluation open Proofdiff @@ -25,6 +24,8 @@ open Changedetectors open Stdarg open Utilities open Zooming +open Defutils +open Envutils module Globmap = Globnames.Refmap diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 5370854..82237dc 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -5,12 +5,11 @@ open Environ open Evd open Utilities open Debruijn -open Coqterms open Hofs open Printing open Convertibility - -module CRD = Context.Rel.Declaration +open Contextutils +open Envutils (* For now, these are lists of pairs of ints, each int representing an index in a different environment; this representation diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index 9e767d3..f4a0c3d 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -5,7 +5,6 @@ open Constr open Environ open Evd open Printing -open Coqterms open Assumptions open Utilities open Merging diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index 1af912d..2bde429 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -4,13 +4,12 @@ open Constr open Environ open Evd open Reducers -open Coqterms open Debruijn open Utilities open Convertibility -open Typeutils - -module CRD = Context.Rel.Declaration +open Typehofs +open Contextutils +open Envutils (* --- TODO for refactoring without breaking things --- *) @@ -45,7 +44,7 @@ let get_app (cut : cut_lemma) = (* Test if a type is exactly the type of the lemma to cut by *) let is_cut_strict env evd lemma typ = try - concls_convertible env evd (reduce_term env lemma) (reduce_term env typ) + concls_convertible env evd (reduce_term env Evd.empty lemma) (reduce_term env Evd.empty typ) with _ -> false @@ -112,7 +111,7 @@ let has_cut_type_app env evd cut trm = let typ = shift (reduce_type env evd trm) in let env_cut = push_rel CRD.(LocalAssum(Names.Name.Anonymous, get_lemma cut)) env in let app = get_app cut in - let app_app = reduce_term env_cut (mkApp (app, Array.make 1 (mkRel 1))) in + let app_app = reduce_term env_cut Evd.empty (mkApp (app, Array.make 1 (mkRel 1))) in let app_app_typ = infer_type env_cut evd app_app in is_cut env_cut evd app_app_typ typ with _ -> diff --git a/plugin/src/representation/merging.ml b/plugin/src/representation/merging.ml index a6d9805..4b7d5d9 100644 --- a/plugin/src/representation/merging.ml +++ b/plugin/src/representation/merging.ml @@ -5,10 +5,10 @@ open Environ open Debruijn open Assumptions open Utilities -open Coqterms - -module CRD = Context.Rel.Declaration +open Contextutils +open Envutils +type closure = env * (types list) type merged_closure = env * types list * types list (* TODO needs cleanup, testing -- and when you test, see if you can change shifting to homogenous *) diff --git a/plugin/src/representation/merging.mli b/plugin/src/representation/merging.mli index 9058739..eb20b0f 100644 --- a/plugin/src/representation/merging.mli +++ b/plugin/src/representation/merging.mli @@ -3,8 +3,8 @@ open Constr open Environ open Assumptions -open Coqterms +type closure = env * (types list) type merged_closure = env * types list * types list (* From 3bb6452a6fc8c35f964809da916fa57ca804f0fe Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 12:22:26 -0700 Subject: [PATCH 038/154] Update plugin deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index fed9cd2..358c053 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit fed9cd2bdff733108332769d596d913c7ef733a0 +Subproject commit 358c053279f15ade011d35fe82015106c2e6d324 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index b12674b..7d06dfe 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit b12674b4b2ea98866d3f0513f7fd220893d8dfff +Subproject commit 7d06dfe3fb40c01a3d1c1bbefa2ed0a213ed1ccb From 90f5fb4a1fa1a0613f0ae38fc007c7e4ce64c668 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 12:23:13 -0700 Subject: [PATCH 039/154] Update coq-plugin-lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index bea3af7..90354bd 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit bea3af7a8b440abfe025649c74ba9912de275bf3 +Subproject commit 90354bdf0fc83797a06c9ae1302af2d7a604cf34 From ab9d4424f967aa27ff017224007c16c6f6b0704f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 12:24:25 -0700 Subject: [PATCH 040/154] Update build script --- plugin/_CoqProject | 14 +++++++------- plugin/src/patch.mlpack | 8 ++++---- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index 32b0f35..bc30044 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -32,13 +32,6 @@ src/coq-plugin-lib/src/coq/termutils/apputils.ml src/coq-plugin-lib/src/coq/termutils/funutils.mli src/coq-plugin-lib/src/coq/termutils/funutils.ml -src/coq-plugin-lib/src/coq/constants/equtils.mli -src/coq-plugin-lib/src/coq/constants/equtils.ml -src/coq-plugin-lib/src/coq/constants/sigmautils.mli -src/coq-plugin-lib/src/coq/constants/sigmautils.ml -src/coq-plugin-lib/src/coq/constants/idutils.mli -src/coq-plugin-lib/src/coq/constants/idutils.ml - src/coq-plugin-lib/src/coq/representationutils/defutils.mli src/coq-plugin-lib/src/coq/representationutils/defutils.ml @@ -47,6 +40,13 @@ src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.ml src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.mli src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.ml +src/coq-plugin-lib/src/coq/constants/equtils.mli +src/coq-plugin-lib/src/coq/constants/equtils.ml +src/coq-plugin-lib/src/coq/constants/sigmautils.mli +src/coq-plugin-lib/src/coq/constants/sigmautils.ml +src/coq-plugin-lib/src/coq/constants/idutils.mli +src/coq-plugin-lib/src/coq/constants/idutils.ml + src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.mli src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.ml src/coq-plugin-lib/src/coq/logicutils/contexts/contextutils.mli diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index 33828a7..b3dfa50 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -3,15 +3,15 @@ Utilities Apputils Funutils -Equtils -Sigmautils -Idutils - Defutils Inference Convertibility +Equtils +Sigmautils +Idutils + Envutils Contextutils From eadcb845b8b0d81bcba9f523efd2e7346a303393 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 12:27:19 -0700 Subject: [PATCH 041/154] get building again (may break) --- plugin/src/core/components/differencing/proofdifferencers.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index a4f3127..ba04ee7 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -187,7 +187,9 @@ let no_diff evd opts (d : goal_proof_diff) : bool = * * TODO: This is incorrect in some cases: * Inside of lambdas, we need to adjust this. + * + * TODO better evar_map hygiene *) let identity_candidates (d : goal_proof_diff) : candidates = let (new_goal, _) = new_proof d in - [identity_term (context_env new_goal) (context_term new_goal)] + [snd (identity_term (context_env new_goal) Evd.empty (context_term new_goal))] From b63bd061a5a031a9de7fb55a41348d7f95bfaad2 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 12:33:49 -0700 Subject: [PATCH 042/154] Fix universe error --- plugin/src/core/components/differencing/proofdifferencers.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index ba04ee7..d338d3d 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -192,4 +192,6 @@ let no_diff evd opts (d : goal_proof_diff) : bool = *) let identity_candidates (d : goal_proof_diff) : candidates = let (new_goal, _) = new_proof d in - [snd (identity_term (context_env new_goal) Evd.empty (context_term new_goal))] + let env = context_env new_goal in + let sigma = Evd.from_env env in + [snd (identity_term (context_env new_goal) sigma (context_term new_goal))] From 70cd0b10c33195dba19622690937ed435f1486d2 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 13:05:56 -0700 Subject: [PATCH 043/154] update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 358c053..41fa56d 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 358c053279f15ade011d35fe82015106c2e6d324 +Subproject commit 41fa56dc8486a3ced7f741da345321b10d0b44f7 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 7d06dfe..bc225e5 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 7d06dfe3fb40c01a3d1c1bbefa2ed0a213ed1ccb +Subproject commit bc225e5376469569fa6af45bf4b31e5319760ac2 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 90354bd..ae4d902 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 90354bdf0fc83797a06c9ae1302af2d7a604cf34 +Subproject commit ae4d902f087e511b24c7b711da8fc31f218f41e1 From 8826b50d4b5f30ab149b529ea662808f8b5791a1 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 13:12:45 -0700 Subject: [PATCH 044/154] fix intern calls --- plugin/src/patcher.ml4 | 29 ++++++++++++++++++----------- 1 file changed, 18 insertions(+), 11 deletions(-) diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 82c07e5..7305fcd 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -73,15 +73,15 @@ let _ = Goptions.declare_bool_option { (* Intern terms corresponding to two definitions *) let intern_defs d1 d2 : types * types = let (evm, env) = Pfedit.get_current_context() in - let d1 = intern env evm d1 in - let d2 = intern env evm d2 in + let evm, d1 = intern env evm d1 in + let evm, d2 = intern env evm d2 in (unwrap_definition env d1, unwrap_definition env d2) (* Initialize diff & search configuration *) let configure trm1 trm2 cut : goal_proof_diff * options = let (evm, env) = Pfedit.get_current_context() in let cut_term = Option.map (intern env evm) cut in - let lemma = Option.map (build_cut_lemma env) cut_term in + let lemma = Option.map (fun evm, t -> build_cut_lemma env t) cut_term in let c1 = eval_proof env trm1 in let c2 = eval_proof env trm2 in let d = add_goals (difference c1 c2 no_assumptions) in @@ -160,7 +160,8 @@ let patch_proof n d_old d_new cut = *) let optimize_proof n d = let (evm, env) = Pfedit.get_current_context () in - let trm = unwrap_definition env (intern env evm d) in + let evm, def = intern env evm d in + let trm = unwrap_definition env def in let (d, opts) = configure_optimize trm in patch n false () (fun env evm _ -> @@ -175,31 +176,36 @@ let optimize_proof n d = *) let patch_theorem n d_old d_new t = let (evm, env) = Pfedit.get_current_context() in - let (old_term, new_term) = (intern env evm d_old, intern env evm d_new) in + let evm, old_term = intern env evm d_old in + let evm, new_term = intern env evm d_new in patch n false t (fun env evm t -> - let theorem = intern env evm t in + let evm, theorem = intern env evm t in let t_trm = lookup_definition env theorem in update_theorem env evm old_term new_term t_trm) (* Invert a term *) let invert n trm : unit = let (evm, env) = Pfedit.get_current_context() in - let body = lookup_definition env (intern env evm trm) in + let evm, def = intern env evm trm in + let body = lookup_definition env def in invert_patch n env evm body (* Specialize a term *) let specialize n trm : unit = let (evm, env) = Pfedit.get_current_context() in let reducer = specialize_body specialize_term in - let specialized = reducer env evm (intern env evm trm) in + let evm, def = intern env evm trm in + let specialized = reducer env evm def in ignore (define_term n evm specialized false) (* Abstract a term by a function or arguments *) let abstract n trm goal : unit = let (evm, env) = Pfedit.get_current_context() in - let c = lookup_definition env (intern env evm trm) in - let goal_type = unwrap_definition env (intern env evm goal) in + let evm, def = intern env evm trm in + let c = lookup_definition env def in + let evm, goal_def = intern env evm goal in + let goal_type = unwrap_definition env goal_def in let config = configure_from_goal env evm goal_type c in let abstracted = abstract_with_strategies config in if List.length abstracted > 0 then @@ -220,7 +226,8 @@ let abstract n trm goal : unit = (* Factor a term into a sequence of lemmas *) let factor n trm : unit = let (evm, env) = Pfedit.get_current_context() in - let body = lookup_definition env (intern env evm trm) in + let evm, def = intern env evm trm in + let body = lookup_definition env def in let fs = reconstruct_factors (factor_term env evm body) in let prefix = Id.to_string n in try From 928b33400e317f48381cdddb628e16e8b5eece76 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 14:44:29 -0700 Subject: [PATCH 045/154] Update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 41fa56d..cb3b8b0 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 41fa56dc8486a3ced7f741da345321b10d0b44f7 +Subproject commit cb3b8b0e9a458ffebb4e0268cbec2cb2912bfc80 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index bc225e5..b19f061 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit bc225e5376469569fa6af45bf4b31e5319760ac2 +Subproject commit b19f0619781e10d55a7073da49094e744057ff94 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index ae4d902..a31ed8f 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit ae4d902f087e511b24c7b711da8fc31f218f41e1 +Subproject commit a31ed8f327881c1769d6255b516b12619bcb61fd From 7b5fb9f6e0ce408d14b6eb3b62564f34559c0f30 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 15:17:28 -0700 Subject: [PATCH 046/154] Update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index cb3b8b0..3d07412 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit cb3b8b0e9a458ffebb4e0268cbec2cb2912bfc80 +Subproject commit 3d074122405a4f7f056f0d5a9362a52ac48965ca diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index b19f061..4f99424 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit b19f0619781e10d55a7073da49094e744057ff94 +Subproject commit 4f994242fe0804980f8ef42136e3041dcf9601ce diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index a31ed8f..7ca6547 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit a31ed8f327881c1769d6255b516b12619bcb61fd +Subproject commit 7ca65477c90bff57bda389dbce7d94f94c58d569 From 6d700903b34d29a5eb2cf86014ca5e5e557fc909 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 16:40:16 -0700 Subject: [PATCH 047/154] update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 3d07412..a61120a 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 3d074122405a4f7f056f0d5a9362a52ac48965ca +Subproject commit a61120a48c65902f0e8eba1b12e712c68f0c3ee8 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 4f99424..286d679 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 4f994242fe0804980f8ef42136e3041dcf9601ce +Subproject commit 286d679b48cf4fd6b870b76090054f521426c051 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 7ca6547..77c5de7 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 7ca65477c90bff57bda389dbce7d94f94c58d569 +Subproject commit 77c5de7b669e7187bd9e6fd8610674722cee992a From 00557fd47d43a7e48fcd7bb8d90f54ae7b74f998 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 16:44:24 -0700 Subject: [PATCH 048/154] get building again --- .../core/components/inversion/inverting.ml | 58 ++++++++++--------- plugin/src/representation/assumptions.ml | 50 ++++++++-------- 2 files changed, 57 insertions(+), 51 deletions(-) diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 2058613..968184d 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -96,34 +96,36 @@ let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_m * swaps above. *) let exploit_type_symmetry (env : env) (evd : evar_map) (trm : types) : types list = - map_subterms_env_if_lazy - (fun _ _ t -> isApp t && is_rewrite (fst (destApp t))) - (fun en _ t -> - let (f, args) = destApp t in - let i_eq = Array.length args - 1 in - let eq = args.(i_eq) in - let eq_type = infer_type en evd eq in - let eq_args = List.append (Array.to_list (snd (destApp eq_type))) [eq] in - let eq_r = mkApp (eq_sym, Array.of_list eq_args) in - let i_src = 1 in - let i_dst = 4 in - let args_r = - Array.mapi - (fun i a -> - if i = i_eq then - eq_r - else if i = i_src then - args.(i_dst) - else if i = i_dst then - args.(i_src) - else - a) - args - in [mkApp (f, args_r)]) - id - env - () - trm + snd + (map_subterms_env_if_lazy + (fun _ _ _ t -> isApp t && is_rewrite (fst (destApp t))) + (fun en evd _ t -> + let (f, args) = destApp t in + let i_eq = Array.length args - 1 in + let eq = args.(i_eq) in + let eq_type = infer_type en evd eq in + let eq_args = List.append (Array.to_list (snd (destApp eq_type))) [eq] in + let eq_r = mkApp (eq_sym, Array.of_list eq_args) in + let i_src = 1 in + let i_dst = 4 in + let args_r = + Array.mapi + (fun i a -> + if i = i_eq then + eq_r + else if i = i_src then + args.(i_dst) + else if i = i_dst then + args.(i_src) + else + a) + args + in evd, [mkApp (f, args_r)]) + id + env + evd + () + trm) (* * Try to exploit symmetry and invert a single factor (like a single diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 82237dc..3474aa3 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -337,17 +337,19 @@ let apply_swaps_combine c a env evd args swaps : 'a list = let all_typ_swaps_combs (env : env) (evd : evar_map) (trm : types) : types list = unique equal - (map_subterms_env_if_lazy - (fun en _ t -> - isApp t) - (fun en _ t -> - let swaps = build_swap_map en evd t in - let (f, args) = destApp t in - apply_swaps_combine (fun s -> mkApp (f, s)) t env evd args swaps) - (fun _ -> ()) - env - () - trm) + (snd + (map_subterms_env_if_lazy + (fun _ _ _ t -> + isApp t) + (fun en evd _ t -> + let swaps = build_swap_map en evd t in + let (f, args) = destApp t in + evd, apply_swaps_combine (fun s -> mkApp (f, s)) t env evd args swaps) + (fun _ -> ()) + env + evd + () + trm)) (* * In an environment, swaps all subterms convertible to the source @@ -359,15 +361,17 @@ let all_typ_swaps_combs (env : env) (evd : evar_map) (trm : types) : types list let all_conv_swaps_combs (env : env) (evd : evar_map) (swaps : swap_map) (trm : types) = unique equal - (map_subterms_env_if_lazy - (fun _ _ t -> isApp t) - (fun en depth t -> - let swaps = shift_swaps_by depth swaps in - let (f, args) = destApp t in - unique - equal - (apply_swaps_combine (fun s -> mkApp (f, s)) t env evd args swaps)) - (fun depth -> depth + 1) - env - 0 - trm) + (snd + (map_subterms_env_if_lazy + (fun _ _ _ t -> isApp t) + (fun en evd depth t -> + let swaps = shift_swaps_by depth swaps in + let (f, args) = destApp t in + evd, unique + equal + (apply_swaps_combine (fun s -> mkApp (f, s)) t env evd args swaps)) + (fun depth -> depth + 1) + env + evd + 0 + trm)) From 3bacddf45fe21bc912a43c013aeb92c0930a4876 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 17:02:25 -0700 Subject: [PATCH 049/154] Don't fix filters yet --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 77c5de7..8ebf4b4 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 77c5de7b669e7187bd9e6fd8610674722cee992a +Subproject commit 8ebf4b42937104bf9e49e64b8878c69ddadebabe From 7ea294a3f53a557c0d5c5b0cd968759c41ef23d3 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 7 Aug 2019 17:27:33 -0700 Subject: [PATCH 050/154] a bit more granular debugging --- plugin/src/patcher.ml4 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 7305fcd..c6358f8 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -115,7 +115,8 @@ let invert_patch n env evm patch = let patch n try_invert a search = let (evm, env) = Pfedit.get_current_context () in let reduce = try_reduce reduce_remove_identities in - let patch = reduce env evm (search env evm a) in + let patch_to_red = search env evm a in + let patch = reduce env evm patch_to_red in let prefix = Id.to_string n in ignore (define_term n evm patch false); (if !opt_printpatches then From dddef19484a4e45fecc55c1c3edf5e05fe63e636 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 10:31:27 -0700 Subject: [PATCH 051/154] Fix one of the two abstraction bugs --- plugin/_CoqProject | 2 + .../components/abstraction/abstracters.ml | 45 ++++++++++++++++--- plugin/src/patch.mlpack | 1 + 3 files changed, 42 insertions(+), 6 deletions(-) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index bc30044..b32f4be 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -39,6 +39,8 @@ src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.mli src/coq-plugin-lib/src/coq/logicutils/typesandequality/inference.ml src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.mli src/coq-plugin-lib/src/coq/logicutils/typesandequality/convertibility.ml +src/coq-plugin-lib/src/coq/logicutils/typesandequality/checking.mli +src/coq-plugin-lib/src/coq/logicutils/typesandequality/checking.ml src/coq-plugin-lib/src/coq/constants/equtils.mli src/coq-plugin-lib/src/coq/constants/equtils.ml diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index c824b1c..9a74fb4 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -108,6 +108,18 @@ let types_full env evd (arg_actual : types) (arg_abstract : types) (trms : candi let types_full_strategy : abstracter = types_full +(* A pattern-based full abstraction strategy for functions *) +(* TODO really just need a more flexible top-level function that lets you combine strategies *) +let function_pattern_full (env : env) (evd : evar_map) (arg_actual : types) (arg_abstract : types) (trms : types list) : types list = + match kind arg_abstract with + | App (f, args) -> + syntactic_full env evd arg_actual arg_abstract trms + | _ -> + types_full env evd arg_actual arg_abstract trms + +let function_pattern_full_strategy : abstracter = + function_pattern_full + (* A pattern-based full abstraction strategy for constructors *) let pattern_full (env : env) (evd : evar_map) (arg_actual : types) (arg_abstract : types) (trms : types list) : types list = let types_conv = types_convertible env evd arg_abstract in @@ -174,6 +186,27 @@ let types_full_reduce : abstraction_strategy = let types_full_no_reduce : abstraction_strategy = { types_full_reduce with reducer = remove_identities; } +(* + * Reduce first + * Replace functions with abstracted functions when types are convertible + * Replace applications with abstracted applications when terms are convertible + *) +let function_pattern_full_reduce : abstraction_strategy = + { + reducer = reduce_remove_identities; + abstracter = function_pattern_full_strategy; + filter = filter_by_type; + to_abstract = Arguments; + } + +(* + * Don't reduce + * Otherwise act like function_pattern_no_reduce + *) +let function_pattern_full_no_reduce : abstraction_strategy = + { function_pattern_full_reduce with reducer = remove_identities; } + + (* * Reduce first * Replace all terms matching a pattern (f, args) with abstracted terms @@ -241,17 +274,17 @@ let simple_strategies : abstraction_strategy list = (* --- Strategies for abstracting properties --- *) -let types_full_reduce_prop : abstraction_strategy = - { types_full_reduce with to_abstract = Property } +let function_pattern_full_reduce_prop : abstraction_strategy = + { function_pattern_full_reduce with to_abstract = Property } -let types_full_no_reduce_prop : abstraction_strategy = - { types_full_no_reduce with to_abstract = Property } +let function_pattern_full_no_reduce_prop : abstraction_strategy = + { function_pattern_full_no_reduce with to_abstract = Property } let reduce_strategies_prop : abstraction_strategy list = - [types_full_reduce_prop] + [function_pattern_full_reduce_prop] let no_reduce_strategies_prop : abstraction_strategy list = - [types_full_no_reduce_prop] + [function_pattern_full_no_reduce_prop] let default_strategies_prop : abstraction_strategy list = List.append reduce_strategies_prop no_reduce_strategies_prop diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index b3dfa50..761ee02 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -7,6 +7,7 @@ Defutils Inference Convertibility +Checking Equtils Sigmautils From 4b732d3b65f97c0ac4f7d888ce993cf063f9951f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 12:52:19 -0700 Subject: [PATCH 052/154] working on fixing induction bug; some progres --- plugin/coq/Induction.v | 83 ++++++++++++++++++- .../components/abstraction/abstracters.ml | 10 ++- .../components/abstraction/abstraction.ml | 27 +++++- .../abstraction/abstractionconfig.ml | 29 +++---- plugin/src/core/procedures/search.ml | 4 +- plugin/src/patcher.ml4 | 16 ++-- plugin/src/representation/cutlemma.ml | 2 +- 7 files changed, 138 insertions(+), 33 deletions(-) diff --git a/plugin/coq/Induction.v b/plugin/coq/Induction.v index bfca953..dc0dc02 100644 --- a/plugin/coq/Induction.v +++ b/plugin/coq/Induction.v @@ -169,7 +169,7 @@ Qed. (** [] *) Theorem bin_to_nat_nat_to_bin : forall n : nat, - bin_to_nat(nat_to_bin(n)) = n. + bin_to_nat (nat_to_bin n) = n. Proof. induction n as [|n']. - reflexivity. @@ -321,6 +321,85 @@ Definition cut := S (a + S a) = S (S (a + a)) -> S (a + S (a + 0)) = S (S (a + (a + 0))). +Definition test_1 (b0 : bin) := + (S ((bin_to_nat b0) + (S ((bin_to_nat b0) + O)))) = (S (S ((bin_to_nat b0) + ((bin_to_nat b0) + O)))). + +Definition test_2 (b0 : bin) := + ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0))))). + + +(* +arg_actual: (S ((bin_to_nat b0) + (S ((bin_to_nat b0) + O)))) = (S (S ((bin_to_nat b0) + ((bin_to_nat b0) + O)))) +arg_abstract: (P ((bin_to_nat b0) + O)) + +trms: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . (eq nat (S (bin_to_nat b0 + (S n))) (S (S ((bin_to_nat b0) + n))))) P ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +abstracted: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +arg_actual: (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) +arg_abstract: P + +trms: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +abstracted: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (_ [Rel 3]) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +1 abstracted candidates +arg_actual: ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0))))) +arg_abstract: (P (bin_to_nat b0)) + +trms: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +abstracted: (λ (_ : ((_) (bin_to_nat b0))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +arg_actual: (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) +arg_abstract: P + +trms: (λ (_ : (P (bin_to_nat b0))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) +abstracted: (λ (_ : (P (bin_to_nat b0))) . (eq_ind nat (bin_to_nat b0) (_ [Rel 3]) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) + +1 abstracted candidates + +need to abstract: ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))) to P n +*) + +(* have: +Definition foo (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)) := + @eq_ind + nat + (bin_to_nat b0) + (fun (n : nat) => ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) + H + ((bin_to_nat b0) + O) + (plus_n_O (bin_to_nat b0)).*) + +(* want: *) +Definition foo_wanted (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)) := + @eq_ind + nat + (bin_to_nat b0) + (fun (n : nat) => P n) + H + ((bin_to_nat b0) + O) + (plus_n_O (bin_to_nat b0)). + +Definition try_alt (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)) := + @eq_ind + nat + (bin_to_nat b0) + P + H + ((bin_to_nat b0) + O) + (plus_n_O (bin_to_nat b0)). +Check try_alt. + +Definition goal_type := + forall (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)), + P ((bin_to_nat b0) + 0). + +Check try_alt. + +(* OK yeah, so we have a term with the right type, but type checking still fails *) + (* Patch *) Patch Proof blindfs_induction.bin_to_nat_pres_incr bin_to_nat_pres_incr cut by (fun (H : cut) b0 => H (bin_to_nat b0)) as patch. Print patch. @@ -547,7 +626,7 @@ Print patch_inv. (* Talia: Now we have an isomorphism. *) Theorem bin_to_nat_nat_to_bin : forall n : nat, - bin_to_nat(nat_to_bin(n)) = n. + bin_to_nat(nat_to_binn) = n. Proof. induction n as [|n']. - reflexivity. diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 9a74fb4..e163d62 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -280,11 +280,17 @@ let function_pattern_full_reduce_prop : abstraction_strategy = let function_pattern_full_no_reduce_prop : abstraction_strategy = { function_pattern_full_no_reduce with to_abstract = Property } +let types_full_reduce_prop : abstraction_strategy = + { types_full_reduce with to_abstract = Property } + +let types_full_no_reduce_prop : abstraction_strategy = + { types_full_no_reduce with to_abstract = Property } + let reduce_strategies_prop : abstraction_strategy list = - [function_pattern_full_reduce_prop] + [function_pattern_full_reduce_prop; types_full_reduce_prop] let no_reduce_strategies_prop : abstraction_strategy list = - [function_pattern_full_no_reduce_prop] + [function_pattern_full_no_reduce_prop; types_full_no_reduce_prop] let default_strategies_prop : abstraction_strategy list = List.append reduce_strategies_prop no_reduce_strategies_prop diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 9029df8..c491782 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -166,6 +166,26 @@ let get_abstraction_opts config strategy : abstraction_options = let num_to_abstract = nb_rel env in { concrete; abstract; goal_type; num_to_abstract } +(* Check whether a term has a given type *) +let has_type (env : env) (sigma : evar_map) (typ : types) (trm : types) : bool = + let sigma, trm_typ = Inference.infer_type env sigma trm in + let open Printing in + debug_term env trm_typ "trm_typ"; + debug_term env typ "typ"; + debug_term env (reduce_nf env sigma trm_typ) "a"; + debug_term env (reduce_nf env sigma typ) "b"; + Convertibility.convertible env sigma trm_typ typ + +(* TODO inline filter_by_type, check intermediate stuff *) +(* Filter trms to those that have type typ in env *) +let filter_by_type typ (env : env) (evd : evar_map) (trms : types list) : types list = + try + List.filter (has_type env evd typ) trms + with + | Pretype_errors.PretypeError (_, _, _) -> + Printf.printf "%s\n\n" "Pretype error"; + [] + (* Abstract candidates with a provided abstraction strategy *) let abstract_with_strategy (config : abstraction_config) strategy : candidates = let opts = get_abstraction_opts config strategy in @@ -179,7 +199,12 @@ let abstract_with_strategy (config : abstraction_config) strategy : candidates = let bs = substitute_using strategy env_abs evd args_adj args_abs cs_adj in let lambdas = generalize env_abs evd opts.num_to_abstract bs in Printf.printf "%d abstracted candidates\n" (List.length lambdas); - filter_using strategy env evd opts.goal_type lambdas + let filtered = filter_using strategy env evd opts.goal_type lambdas in + let open Printing in + debug_terms env lambdas "lambdas"; + debug_terms env filtered "filtered"; + debug_term env opts.goal_type "goal_type"; + filtered (* * Try to abstract candidates with an ordered list of abstraction strategies diff --git a/plugin/src/core/components/abstraction/abstractionconfig.ml b/plugin/src/core/components/abstraction/abstractionconfig.ml index 0783cd1..73faf46 100644 --- a/plugin/src/core/components/abstraction/abstractionconfig.ml +++ b/plugin/src/core/components/abstraction/abstractionconfig.ml @@ -9,19 +9,7 @@ open Proofdiff open Cutlemma open Contextutils open Envutils - -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = - let jmt = Typeops.infer env trm in - j_type jmt - -(* --- End TODO --- *) +open Inference (* --- Configuring Abstraction --- *) @@ -59,10 +47,14 @@ let rec configure_goal_body env evd goal c : abstraction_config = | (Prod (_, _, gb), Lambda (n, t, cb)) when isProd gb && isLambda cb -> configure_goal_body (push_rel CRD.(LocalAssum(n, t)) env) evd gb cb | (Prod (_, gt, gb), Lambda (_, _, _)) when isApp gt && isApp gb -> - let (_, ctt, ctb) = destProd (infer_type env evd c) in + let evd, c_typ = infer_type env evd c in + let (_, ctt, ctb) = destProd c_typ in if isApp ctb then let cs = [c] in let args_base = Array.to_list (snd (destApp gt)) in + let open Printing in + debug_terms (push_local (Anonymous, ctt) env) (Array.to_list (snd (destApp gb))) "args_goal"; + debug_terms env (List.map unshift (Array.to_list (snd (destApp gb)))) "args_goal unshifted"; let args_goal = List.map unshift (Array.to_list (snd (destApp gb))) in if List.for_all2 equal args_base args_goal then (* argument *) if isApp ctt then @@ -129,8 +121,9 @@ let rec push_prop env evd typ : env = | Prod (n, t, b) -> push_prop (push_rel CRD.(LocalAssum(n, t)) env) evd b | App (f, _) -> + let evd, f_typ = infer_type env evd f in push_rel - CRD.(LocalAssum(Names.Name.Anonymous, infer_type env evd f)) + CRD.(LocalAssum(Names.Name.Anonymous, f_typ)) (pop_rel_context (nb_rel env) env) | _ -> failwith "Could not find function to abstract" @@ -146,7 +139,8 @@ let configure_fixpoint_cases env evd (diffs : types list) (cs : candidates) = (fun goal -> List.map (fun c -> - let env_prop = push_prop env evd (infer_type env evd c) in + let evd, prop = infer_type env evd c in + let env_prop = push_prop env evd prop in configure_goal_body env_prop evd goal c) cs) goals @@ -169,7 +163,8 @@ let rec configure_args_cut_app env evd (app : types) cs : abstraction_config = | _ -> failwith "Could not infer arguments to generalize" in - let (f_base, f_goal) = get_lemma_functions (infer_type env evd f) in + let evd, f_typ = infer_type env evd f in + let (f_base, f_goal) = get_lemma_functions f_typ in let args_base = Array.to_list args in let args_goal = args_base in let strategies = no_reduce_strategies in diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index 99bc852..af620ab 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -57,13 +57,13 @@ let return_patch opts env evd (patches : types list) : types = evd (diff_fix_cases env evd (difference old_type new_type no_assumptions)) specialized_fs_terms) - in List.hd generalized + in List.hd generalized (* TODO better failure when none found *) | ConclusionCase (Some cut) -> let patches = reduce_all remove_unused_hypos env evd patches in let generalized = abstract_with_strategies (configure_cut_args env evd cut patches) - in List.hd generalized + in List.hd generalized (* TODO better failure when none found *) | Hypothesis (_, _) -> let patches = reduce_all remove_unused_hypos env evd patches in List.hd patches diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index c6358f8..cdaef57 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -71,11 +71,11 @@ let _ = Goptions.declare_bool_option { (* --- Auxiliary functionality for top-level functions --- *) (* Intern terms corresponding to two definitions *) -let intern_defs d1 d2 : types * types = +let intern_defs d1 d2 : evar_map * types * types = let (evm, env) = Pfedit.get_current_context() in let evm, d1 = intern env evm d1 in let evm, d2 = intern env evm d2 in - (unwrap_definition env d1, unwrap_definition env d2) + (evm, unwrap_definition env d1, unwrap_definition env d2) (* Initialize diff & search configuration *) let configure trm1 trm2 cut : goal_proof_diff * options = @@ -112,8 +112,7 @@ let invert_patch n env evm patch = failwith "Could not find a well-typed inverted term" (* Common patch command functionality *) -let patch n try_invert a search = - let (evm, env) = Pfedit.get_current_context () in +let patch env evm n try_invert a search = let reduce = try_reduce reduce_remove_identities in let patch_to_red = search env evm a in let patch = reduce env evm patch_to_red in @@ -141,11 +140,12 @@ let patch n try_invert a search = * The latter two just pass extra guidance for now *) let patch_proof n d_old d_new cut = - let (old_term, new_term) = intern_defs d_old d_new in + let (evm, env) = Pfedit.get_current_context () in + let (evm, old_term, new_term) = intern_defs d_old d_new in let (d, opts) = configure old_term new_term cut in let change = get_change opts in let try_invert = not (is_conclusion change || is_hypothesis change) in - patch n try_invert () + patch env evm n try_invert () (fun env evm _ -> search_for_patch evm old_term opts d) @@ -164,7 +164,7 @@ let optimize_proof n d = let evm, def = intern env evm d in let trm = unwrap_definition env def in let (d, opts) = configure_optimize trm in - patch n false () + patch env evm n false () (fun env evm _ -> search_for_patch evm trm opts d) @@ -179,7 +179,7 @@ let patch_theorem n d_old d_new t = let (evm, env) = Pfedit.get_current_context() in let evm, old_term = intern env evm d_old in let evm, new_term = intern env evm d_new in - patch n false t + patch env evm n false t (fun env evm t -> let evm, theorem = intern env evm t in let t_trm = lookup_definition env theorem in diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index 2bde429..5784db0 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -44,7 +44,7 @@ let get_app (cut : cut_lemma) = (* Test if a type is exactly the type of the lemma to cut by *) let is_cut_strict env evd lemma typ = try - concls_convertible env evd (reduce_term env Evd.empty lemma) (reduce_term env Evd.empty typ) + concls_convertible env evd (reduce_term env evd lemma) (reduce_term env evd typ) with _ -> false From a99bb6557cf01ac10fe31a8bf8ca627052ea9e6b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 13:04:35 -0700 Subject: [PATCH 053/154] remove comments --- plugin/coq/Induction.v | 72 ------------------------------------------ 1 file changed, 72 deletions(-) diff --git a/plugin/coq/Induction.v b/plugin/coq/Induction.v index dc0dc02..94925e7 100644 --- a/plugin/coq/Induction.v +++ b/plugin/coq/Induction.v @@ -328,78 +328,6 @@ Definition test_2 (b0 : bin) := ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0))))). -(* -arg_actual: (S ((bin_to_nat b0) + (S ((bin_to_nat b0) + O)))) = (S (S ((bin_to_nat b0) + ((bin_to_nat b0) + O)))) -arg_abstract: (P ((bin_to_nat b0) + O)) - -trms: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . (eq nat (S (bin_to_nat b0 + (S n))) (S (S ((bin_to_nat b0) + n))))) P ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -abstracted: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -arg_actual: (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) -arg_abstract: P - -trms: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -abstracted: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (_ [Rel 3]) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -1 abstracted candidates -arg_actual: ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0))))) -arg_abstract: (P (bin_to_nat b0)) - -trms: (λ (_ : ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0)))))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -abstracted: (λ (_ : ((_) (bin_to_nat b0))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -arg_actual: (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) -arg_abstract: P - -trms: (λ (_ : (P (bin_to_nat b0))) . (eq_ind nat (bin_to_nat b0) (λ (n : nat) . ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) -abstracted: (λ (_ : (P (bin_to_nat b0))) . (eq_ind nat (bin_to_nat b0) (_ [Rel 3]) (_) ((bin_to_nat b0) + O) (plus_n_O (bin_to_nat b0)))) - -1 abstracted candidates - -need to abstract: ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))) to P n -*) - -(* have: -Definition foo (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)) := - @eq_ind - nat - (bin_to_nat b0) - (fun (n : nat) => ((S ((bin_to_nat b0) + (S n))) = (S (S ((bin_to_nat b0) + n))))) - H - ((bin_to_nat b0) + O) - (plus_n_O (bin_to_nat b0)).*) - -(* want: *) -Definition foo_wanted (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)) := - @eq_ind - nat - (bin_to_nat b0) - (fun (n : nat) => P n) - H - ((bin_to_nat b0) + O) - (plus_n_O (bin_to_nat b0)). - -Definition try_alt (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)) := - @eq_ind - nat - (bin_to_nat b0) - P - H - ((bin_to_nat b0) + O) - (plus_n_O (bin_to_nat b0)). -Check try_alt. - -Definition goal_type := - forall (P : nat -> Prop) (b0 : bin) (H : P (bin_to_nat b0)), - P ((bin_to_nat b0) + 0). - -Check try_alt. - -(* OK yeah, so we have a term with the right type, but type checking still fails *) - (* Patch *) Patch Proof blindfs_induction.bin_to_nat_pres_incr bin_to_nat_pres_incr cut by (fun (H : cut) b0 => H (bin_to_nat b0)) as patch. Print patch. From 3630e1cdc20e4e7bc49cdde2815d3fc26bd87cb4 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 13:12:55 -0700 Subject: [PATCH 054/154] Update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index a61120a..d58f5c3 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit a61120a48c65902f0e8eba1b12e712c68f0c3ee8 +Subproject commit d58f5c372d7226b9c3efc4e7e22fc9488193a1e7 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 286d679..cc5f194 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 286d679b48cf4fd6b870b76090054f521426c051 +Subproject commit cc5f1940ab0d0ef7224dd750d9bc8544e87f4702 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 8ebf4b4..c221d98 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 8ebf4b42937104bf9e49e64b8878c69ddadebabe +Subproject commit c221d9841e0a6482d8d14a46d64bdc1e98a4487c From d1dc029ddbf96ed3f7ef5dcdeac82d5ffbb965da Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 13:15:34 -0700 Subject: [PATCH 055/154] Remove comments --- .../components/abstraction/abstraction.ml | 27 +------------------ .../abstraction/abstractionconfig.ml | 3 --- 2 files changed, 1 insertion(+), 29 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index c491782..af742d9 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -165,26 +165,6 @@ let get_abstraction_opts config strategy : abstraction_options = let (env, _) = concrete in let num_to_abstract = nb_rel env in { concrete; abstract; goal_type; num_to_abstract } - -(* Check whether a term has a given type *) -let has_type (env : env) (sigma : evar_map) (typ : types) (trm : types) : bool = - let sigma, trm_typ = Inference.infer_type env sigma trm in - let open Printing in - debug_term env trm_typ "trm_typ"; - debug_term env typ "typ"; - debug_term env (reduce_nf env sigma trm_typ) "a"; - debug_term env (reduce_nf env sigma typ) "b"; - Convertibility.convertible env sigma trm_typ typ - -(* TODO inline filter_by_type, check intermediate stuff *) -(* Filter trms to those that have type typ in env *) -let filter_by_type typ (env : env) (evd : evar_map) (trms : types list) : types list = - try - List.filter (has_type env evd typ) trms - with - | Pretype_errors.PretypeError (_, _, _) -> - Printf.printf "%s\n\n" "Pretype error"; - [] (* Abstract candidates with a provided abstraction strategy *) let abstract_with_strategy (config : abstraction_config) strategy : candidates = @@ -199,12 +179,7 @@ let abstract_with_strategy (config : abstraction_config) strategy : candidates = let bs = substitute_using strategy env_abs evd args_adj args_abs cs_adj in let lambdas = generalize env_abs evd opts.num_to_abstract bs in Printf.printf "%d abstracted candidates\n" (List.length lambdas); - let filtered = filter_using strategy env evd opts.goal_type lambdas in - let open Printing in - debug_terms env lambdas "lambdas"; - debug_terms env filtered "filtered"; - debug_term env opts.goal_type "goal_type"; - filtered + filter_using strategy env evd opts.goal_type lambdas (* * Try to abstract candidates with an ordered list of abstraction strategies diff --git a/plugin/src/core/components/abstraction/abstractionconfig.ml b/plugin/src/core/components/abstraction/abstractionconfig.ml index 73faf46..74d5b22 100644 --- a/plugin/src/core/components/abstraction/abstractionconfig.ml +++ b/plugin/src/core/components/abstraction/abstractionconfig.ml @@ -52,9 +52,6 @@ let rec configure_goal_body env evd goal c : abstraction_config = if isApp ctb then let cs = [c] in let args_base = Array.to_list (snd (destApp gt)) in - let open Printing in - debug_terms (push_local (Anonymous, ctt) env) (Array.to_list (snd (destApp gb))) "args_goal"; - debug_terms env (List.map unshift (Array.to_list (snd (destApp gb)))) "args_goal unshifted"; let args_goal = List.map unshift (Array.to_list (snd (destApp gb))) in if List.for_all2 equal args_base args_goal then (* argument *) if isApp ctt then From 524f8b1d383189ba2c2e1155895236b08bb22a5d Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 13:38:20 -0700 Subject: [PATCH 056/154] Don't need extra strategy after all --- plugin/src/core/components/abstraction/abstracters.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index e163d62..516ae22 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -287,10 +287,10 @@ let types_full_no_reduce_prop : abstraction_strategy = { types_full_no_reduce with to_abstract = Property } let reduce_strategies_prop : abstraction_strategy list = - [function_pattern_full_reduce_prop; types_full_reduce_prop] + [function_pattern_full_reduce_prop] let no_reduce_strategies_prop : abstraction_strategy list = - [function_pattern_full_no_reduce_prop; types_full_no_reduce_prop] + [function_pattern_full_no_reduce_prop] let default_strategies_prop : abstraction_strategy list = List.append reduce_strategies_prop no_reduce_strategies_prop From 17c25850a085abfa96389501c3692b25c3c77435 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 14:04:05 -0700 Subject: [PATCH 057/154] Finish fixing bugs from evar refactor --- plugin/coq/Induction.v | 2 +- plugin/src/core/components/abstraction/abstracters.ml | 7 ++++++- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/plugin/coq/Induction.v b/plugin/coq/Induction.v index 94925e7..6984f80 100644 --- a/plugin/coq/Induction.v +++ b/plugin/coq/Induction.v @@ -554,7 +554,7 @@ Print patch_inv. (* Talia: Now we have an isomorphism. *) Theorem bin_to_nat_nat_to_bin : forall n : nat, - bin_to_nat(nat_to_binn) = n. + bin_to_nat (nat_to_bin n) = n. Proof. induction n as [|n']. - reflexivity. diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 516ae22..2651391 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -53,7 +53,12 @@ let sort_dependent args args_abstract = let substitute_using (strategy : abstraction_strategy) (env : env) (evd : evar_map) (args : types list) (args_abstract : types list) (cs : candidates) : candidates = let abs = strategy.abstracter in let num_args = List.length args_abstract in - let (args_sorted, args_abstract_sorted) = sort_dependent args args_abstract in + let (args_sorted, args_abstract_sorted) = + if strategy.to_abstract = Property then + (List.rev args, List.rev args_abstract) (* TODO refactor/simplify *) + else + sort_dependent args args_abstract + in if num_args > 0 then let cs_abs = abs env evd (last args_sorted) (last args_abstract_sorted) cs in List.fold_right2 From 53a5c652b314a546642efc05687ecbb150c308b7 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 15:25:31 -0700 Subject: [PATCH 058/154] Update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index d58f5c3..ffb0125 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit d58f5c372d7226b9c3efc4e7e22fc9488193a1e7 +Subproject commit ffb012527dc44b478e0c555f30367ab0e5056f13 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index cc5f194..e29fb11 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit cc5f1940ab0d0ef7224dd750d9bc8544e87f4702 +Subproject commit e29fb117e47e4c9e1424ecc922336c540cfe5fba diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index c221d98..c46ecc1 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit c221d9841e0a6482d8d14a46d64bdc1e98a4487c +Subproject commit c46ecc17a658566739f66b7881f0b3fb6c4273ca From 3040b52f841ef6e632dfa76f983f50bb0ecd6e8b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 15:36:24 -0700 Subject: [PATCH 059/154] Update code to use updated library --- plugin/src/core/components/factoring/factoring.ml | 3 ++- plugin/src/core/components/inversion/inverting.ml | 3 ++- plugin/src/core/procedures/search.ml | 2 +- plugin/src/representation/cutlemma.ml | 10 +++++----- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index c628129..8a9d679 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -92,7 +92,8 @@ let rec find_path (env : env) (evd : evar_map) (trm : types) : factors = let assume_arg i a = apply_assumption (Array.get paths i) a in let args_assumed = Array.mapi assume_arg args in try - let t = unshift (reduce_type env_arg evd arg) in + let evd, arg_typ = reduce_type env_arg evd arg in + let t = unshift arg_typ in (assume env Anonymous t, mkApp (f, args_assumed)) :: path with _ -> [] diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 968184d..5c2580e 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -159,7 +159,8 @@ let invert_factor evd (env, rp) : (env * types) option = match kind rp with | Lambda (n, old_goal_type, body) -> let env_body = push_rel CRD.(LocalAssum(n, old_goal_type)) env in - let new_goal_type = unshift (reduce_type env_body evd body) in + let evd, body_type = reduce_type env_body evd body in + let new_goal_type = unshift body_type in let rp_goal = all_conv_substs env evd (old_goal_type, new_goal_type) rp in let goal_type = mkProd (n, new_goal_type, shift old_goal_type) in let flipped = exploit_type_symmetry env evd rp_goal in diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index af620ab..a6c881d 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -44,7 +44,7 @@ let return_patch opts env evd (patches : types list) : types = match get_change opts with | FixpointCase ((old_type, new_type), cut) -> let body_reducer = specialize_in (get_app cut) specialize_term in - let reduction_condition en tr = has_cut_type_strict_sym en evd cut tr in + let reduction_condition en evd tr = has_cut_type_strict_sym en evd cut tr in let reducer = reduce_body_if reduction_condition body_reducer in let specialized = List.map (reducer env evd) patches in let specialized_fs = List.map (factor_term env evd) specialized in diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index 5784db0..144cdc9 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -50,8 +50,8 @@ let is_cut_strict env evd lemma typ = (* Test if a term has exactly the type of the lemma to cut by *) let has_cut_type_strict env evd cut trm = - try - on_type (is_cut_strict env evd (get_lemma cut)) env evd trm + try (* TODO do we need red type here or not? same everywhere *) + on_red_type_default (fun env evd -> is_cut_strict env evd (get_lemma cut)) env evd trm with _ -> false @@ -74,7 +74,7 @@ let rec flip_concls lemma = *) let has_cut_type_strict_rev env evd cut trm = try - on_type (is_cut_strict env evd (flip_concls (get_lemma cut))) env evd trm + on_red_type_default (fun env evd -> is_cut_strict env evd (flip_concls (get_lemma cut))) env evd trm with _ -> false @@ -101,14 +101,14 @@ let rec is_cut env evd lemma typ = (* Check if a term has loosely the cut lemma type (can have extra hypotheses) *) let has_cut_type env evd cut trm = try - on_type (is_cut env evd (get_lemma cut)) env evd trm + on_red_type_default (fun env evd -> is_cut env evd (get_lemma cut)) env evd trm with _ -> false (* Check if a term is loosely an application of the lemma to cut by *) let has_cut_type_app env evd cut trm = try - let typ = shift (reduce_type env evd trm) in + let evd, typ = on_red_type_default (fun env evd trm -> evd, shift trm) env evd trm in let env_cut = push_rel CRD.(LocalAssum(Names.Name.Anonymous, get_lemma cut)) env in let app = get_app cut in let app_app = reduce_term env_cut Evd.empty (mkApp (app, Array.make 1 (mkRel 1))) in From c68bad87f099041a4491585d8ad54dd59e9bcb23 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 9 Aug 2019 17:10:40 -0700 Subject: [PATCH 060/154] Update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index ffb0125..ea4f255 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit ffb012527dc44b478e0c555f30367ab0e5056f13 +Subproject commit ea4f255442ef38fac4bf7d8b376890adedee84ff diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index e29fb11..619c03d 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit e29fb117e47e4c9e1424ecc922336c540cfe5fba +Subproject commit 619c03da1044c90bba3916fa47d765580cd8783e diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index c46ecc1..2e6c06a 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit c46ecc17a658566739f66b7881f0b3fb6c4273ca +Subproject commit 2e6c06a2e755837de1fa155b44838a0cf04a5b91 From 666a7853888475f9a8b38add78ea3ea7733e0dd3 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Sun, 11 Aug 2019 16:16:27 -0700 Subject: [PATCH 061/154] Update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index ea4f255..09af7fd 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit ea4f255442ef38fac4bf7d8b376890adedee84ff +Subproject commit 09af7fdb7d7e57e80ed0f82efd38328da24c94aa diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 619c03d..64ca082 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 619c03da1044c90bba3916fa47d765580cd8783e +Subproject commit 64ca082977a5a3caba4094e102a4a1651f2ed9a3 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 2e6c06a..b0d958e 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 2e6c06a2e755837de1fa155b44838a0cf04a5b91 +Subproject commit b0d958e1a39c53ed211ad5071dba99d44e7f2dc8 From 6e9689b7bbdb8ca9d3c11359146ae210c3ff7d08 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 13 Aug 2019 10:37:35 -0700 Subject: [PATCH 062/154] Update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 09af7fd..663656e 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 09af7fdb7d7e57e80ed0f82efd38328da24c94aa +Subproject commit 663656e18726658b6022e9bdb95a53901e8123dd diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 64ca082..b1675fd 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 64ca082977a5a3caba4094e102a4a1651f2ed9a3 +Subproject commit b1675fd13137bc374d50971989ba4cbd00462f45 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index b0d958e..ab534b0 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit b0d958e1a39c53ed211ad5071dba99d44e7f2dc8 +Subproject commit ab534b01cfc849bbb61a2e6f013c4766a2c26cfd From dcab29f0f07bf58a604ff14c9698678447a1bb6b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 13 Aug 2019 10:39:04 -0700 Subject: [PATCH 063/154] Load missing library file --- plugin/_CoqProject | 2 ++ plugin/src/patch.mlpack | 1 + 2 files changed, 3 insertions(+) diff --git a/plugin/_CoqProject b/plugin/_CoqProject index b32f4be..94d7e2d 100644 --- a/plugin/_CoqProject +++ b/plugin/_CoqProject @@ -49,6 +49,8 @@ src/coq-plugin-lib/src/coq/constants/sigmautils.ml src/coq-plugin-lib/src/coq/constants/idutils.mli src/coq-plugin-lib/src/coq/constants/idutils.ml +src/coq-plugin-lib/src/coq/logicutils/contexts/stateutils.mli +src/coq-plugin-lib/src/coq/logicutils/contexts/stateutils.ml src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.mli src/coq-plugin-lib/src/coq/logicutils/contexts/envutils.ml src/coq-plugin-lib/src/coq/logicutils/contexts/contextutils.mli diff --git a/plugin/src/patch.mlpack b/plugin/src/patch.mlpack index 761ee02..b53108e 100644 --- a/plugin/src/patch.mlpack +++ b/plugin/src/patch.mlpack @@ -13,6 +13,7 @@ Equtils Sigmautils Idutils +Stateutils Envutils Contextutils From 93dce0371636bed4e41e7054c3bed0d3320f844f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 13 Aug 2019 10:50:41 -0700 Subject: [PATCH 064/154] reverse compatibility --- plugin/src/compilation/expansion.ml | 4 +++- plugin/src/compilation/proofdiff.ml | 8 +++++++- plugin/src/configuration/searchopts.ml | 8 +++++++- plugin/src/core/components/abstraction/abstracters.ml | 8 +++++++- plugin/src/core/components/abstraction/abstraction.ml | 4 +++- .../src/core/components/differencing/appdifferencers.ml | 8 +++++++- .../src/core/components/differencing/changedetectors.ml | 8 +++++++- .../src/core/components/differencing/fixdifferencers.ml | 8 +++++++- .../src/core/components/differencing/proofdifferencers.ml | 4 +++- plugin/src/core/components/factoring/factoring.ml | 8 +++++++- plugin/src/core/components/inversion/inverting.ml | 4 +++- plugin/src/core/procedures/theorem.ml | 4 +++- plugin/src/representation/assumptions.ml | 8 +++++++- plugin/src/representation/categories/proofcat.ml | 8 +++++++- plugin/src/representation/cutlemma.ml | 8 ++++++-- 15 files changed, 84 insertions(+), 16 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 8f414f0..addcdd3 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -10,7 +10,6 @@ open Evaluation open Utilities open Debruijn open Declarations -open Convertibility open Indutils open Contextutils @@ -25,6 +24,9 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + (* Check whether a term has a given type *) let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool = try diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 03a46f2..28e3a33 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -12,7 +12,6 @@ open Reducers open Declarations open Utilities open Merging -open Convertibility open Indutils (* @@ -20,6 +19,13 @@ open Indutils * when we refactor later. *) +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) + (* --- Types --- *) type 'a proof_diff = 'a * 'a * equal_assumptions diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index 61e43d9..268f903 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -11,7 +11,6 @@ open Assumptions open Kindofchange open Cutlemma open Catzooming -open Convertibility open Indutils open Contextutils @@ -20,6 +19,13 @@ open Contextutils * we merge PUMPKIN with DEVOID and refactor. *) +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) + (* --- Auxiliary --- *) let terms_convertible env_o env_n evd src_o src_n dst_o dst_n = diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 2651391..8471d8a 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -8,7 +8,13 @@ open Substitution open Reducers open Filters open Candidates -open Convertibility + +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) type abstraction_dimension = Arguments | Property type abstracter = env -> evar_map -> types -> types -> candidates -> candidates diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index af742d9..ce58934 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -16,7 +16,6 @@ open Searchopts open Cutlemma open Filters open Zooming -open Convertibility open Contextutils open Merging open Apputils @@ -31,6 +30,9 @@ open Apputils let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) (* --- End TODO --- *) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 2abc09c..e034793 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -16,7 +16,13 @@ open Zooming open Catzooming open Debruijn open Filters -open Convertibility + +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) (* * Given a search function and a difference between terms, diff --git a/plugin/src/core/components/differencing/changedetectors.ml b/plugin/src/core/components/differencing/changedetectors.ml index d00ac19..0390b41 100644 --- a/plugin/src/core/components/differencing/changedetectors.ml +++ b/plugin/src/core/components/differencing/changedetectors.ml @@ -10,9 +10,15 @@ open Reducers open Assumptions open Utilities open Zooming -open Convertibility open Contextutils +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) + (* * If the kind of change is a change in conclusion, then * determine whether the first different term is a constructor or diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index 0d29bd8..39585a6 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -11,10 +11,16 @@ open Debruijn open Higherdifferencers open Evd open Zooming -open Convertibility open Contextutils open Envutils +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) + (* --- Cases --- *) (* diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index d338d3d..4032caf 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -14,7 +14,6 @@ open Reducers open Kindofchange open Names open Zooming -open Convertibility open Contextutils open Idutils @@ -28,6 +27,9 @@ open Idutils let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) (* --- End TODO --- *) diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index 8a9d679..202282a 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -8,7 +8,6 @@ open Specialization open Names open Utilities open Debruijn -open Convertibility open Reducers open Contextutils @@ -16,6 +15,13 @@ type factors = (env * types) list open Zooming +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) + (* --- Assumptions for path finding --- *) let assumption : types = mkRel 1 diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 5c2580e..57986ab 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -11,7 +11,6 @@ open Assumptions open Hofs open Filters open Factoring -open Convertibility open Reducers open Contextutils open Equtils @@ -28,6 +27,9 @@ type inverter = evar_map -> (env * types) -> (env * types) option let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) (* --- End TODO --- *) diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 7aa93bc..9c5564b 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -8,7 +8,6 @@ open Reducers open Specialization open Evd open Zooming -open Convertibility open Contextutils (* --- TODO for refactoring without breaking things --- *) @@ -21,6 +20,9 @@ open Contextutils let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) (* --- End TODO --- *) diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 3474aa3..d389245 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -7,7 +7,6 @@ open Utilities open Debruijn open Hofs open Printing -open Convertibility open Contextutils open Envutils @@ -23,6 +22,13 @@ let no_assumptions = [] let no_substitutions = [] let no_swaps = [] +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) + (* --- Auxiliary functions on assumptions --- *) (* Print a list of substitutions for debugging purposes *) diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index f4a0c3d..e1c0526 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -8,12 +8,18 @@ open Printing open Assumptions open Utilities open Merging -open Convertibility (* * Note: Evar discipline is currently very bad here. But, we will eventually * get rid of this representation, so it is not worth fixing in the meantime. *) + +(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +(* --- End TODO --- *) (* --- Type definitions --- *) diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index 144cdc9..6873c2b 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -6,7 +6,6 @@ open Evd open Reducers open Debruijn open Utilities -open Convertibility open Typehofs open Contextutils open Envutils @@ -21,7 +20,12 @@ open Envutils let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt - + +let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) +let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + +let concls_convertible env sigma t1 t2 = snd (Convertibility.concls_convertible env sigma t1 t2) + (* --- End TODO --- *) type cut_lemma = From cd8d4f03826a06268584e520d569fa2e44ebc004 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 13 Aug 2019 11:45:20 -0700 Subject: [PATCH 065/154] update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 663656e..a8f5397 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 663656e18726658b6022e9bdb95a53901e8123dd +Subproject commit a8f53976063337db4ecdeb020602323769bfa2e1 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index b1675fd..47781d0 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit b1675fd13137bc374d50971989ba4cbd00462f45 +Subproject commit 47781d0097e84873dd3f800b34d5d074a9659aec diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index ab534b0..556a574 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit ab534b01cfc849bbb61a2e6f013c4766a2c26cfd +Subproject commit 556a574db3b9e3ba24ac30d9fd1dd45bc45226a4 From c6614d0e515e715c115dad379486f7efa53fb768 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 13 Aug 2019 11:53:03 -0700 Subject: [PATCH 066/154] backwads compat --- plugin/src/core/components/abstraction/abstracters.ml | 8 ++++---- .../src/core/components/differencing/proofdifferencers.ml | 4 ++-- plugin/src/core/components/inversion/inverting.ml | 4 ++-- plugin/src/core/procedures/theorem.ml | 4 ++-- plugin/src/representation/assumptions.ml | 6 +++--- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 8471d8a..501f7ef 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -104,7 +104,7 @@ let syntactic_full env evd (arg_actual : types) (arg_abstract : types) (trms : c if equal arg_actual arg_abstract then trms else - List.map (all_conv_substs env evd (arg_actual, arg_abstract)) trms + List.map (fun tr -> snd (all_conv_substs env evd (arg_actual, arg_abstract) tr)) trms (* TODO evar_maps *) let syntactic_full_strategy : abstracter = syntactic_full @@ -114,7 +114,7 @@ let types_full env evd (arg_actual : types) (arg_abstract : types) (trms : candi if equal arg_actual arg_abstract then trms else - List.map (all_typ_substs env evd (arg_actual, arg_abstract)) trms + List.map (fun tr -> snd (all_typ_substs env evd (arg_actual, arg_abstract) tr)) trms (* TODO evar_maps *) let types_full_strategy : abstracter = types_full @@ -138,7 +138,7 @@ let pattern_full (env : env) (evd : evar_map) (arg_actual : types) (arg_abstract match map_tuple kind (arg_actual, arg_abstract) with | (App (f, args), _) when exists_types_conv (Array.to_list args) -> let arg = List.find types_conv (Array.to_list args) in - let sub = all_constr_substs env evd f in + let sub tr = snd (all_constr_substs env evd f tr) in (* TODO evar_map *) syntactic_full env evd arg arg_abstract (List.map sub trms) | _ -> trms @@ -151,7 +151,7 @@ let syntactic_all_combinations env evd (arg_actual : types) (arg_abstract : type if equal arg_actual arg_abstract then trms else - flat_map (all_conv_substs_combs env evd (arg_actual, arg_abstract)) trms + flat_map (fun tr -> snd (all_conv_substs_combs env evd (arg_actual, arg_abstract) tr)) trms (* TODO evar_map *) let syntactic_all_strategy : abstracter = syntactic_all_combinations diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index 4032caf..f304d0e 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -55,7 +55,7 @@ let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible en let sub_new_ih is_ind num_new_rels env evd (old_term : types) : types = if is_ind then let ih_new = mkRel (1 + num_new_rels) in - all_typ_substs env evd (ih_new, ih_new) old_term + snd (all_typ_substs env evd (ih_new, ih_new) old_term) (* TODO evar_map *) else old_term @@ -104,7 +104,7 @@ let build_app_candidates env evd opts (from_type : types) (old_term : types) (ne else (* otherwise, check containment *) let new_term_shift = shift new_term in - let sub = all_conv_substs_combs env_b evd (new_term_shift, (mkRel 1)) in + let sub tr = snd (all_conv_substs_combs env_b evd (new_term_shift, (mkRel 1)) tr) in (* TODO evar_map *) filter_not_same old_term_shift env_b evd (sub old_term_shift) in List.map (fun b -> reconstruct_lambda_n env_b b (nb_rel env)) bodies with _ -> diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 57986ab..05f184b 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -100,7 +100,7 @@ let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_m let exploit_type_symmetry (env : env) (evd : evar_map) (trm : types) : types list = snd (map_subterms_env_if_lazy - (fun _ _ _ t -> isApp t && is_rewrite (fst (destApp t))) + (fun _ evd _ t -> evd, isApp t && is_rewrite (fst (destApp t))) (fun en evd _ t -> let (f, args) = destApp t in let i_eq = Array.length args - 1 in @@ -163,7 +163,7 @@ let invert_factor evd (env, rp) : (env * types) option = let env_body = push_rel CRD.(LocalAssum(n, old_goal_type)) env in let evd, body_type = reduce_type env_body evd body in let new_goal_type = unshift body_type in - let rp_goal = all_conv_substs env evd (old_goal_type, new_goal_type) rp in + let rp_goal = snd (all_conv_substs env evd (old_goal_type, new_goal_type) rp) in (* TODO evar_map *) let goal_type = mkProd (n, new_goal_type, shift old_goal_type) in let flipped = exploit_type_symmetry env evd rp_goal in let flipped_wt = filter_by_type goal_type env evd flipped in diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 9c5564b..9e59ea1 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -107,11 +107,11 @@ let update_theorem env evd (src : types) (dst : types) (trm : types) : types = let num_hs = nb_rel env in let num_src_hs = nb_rel env_s - num_hs in let num_dst_hs = nb_rel env_d - num_hs in - let patch = all_conv_substs env evd (src, dst) trm in + let patch = snd (all_conv_substs env evd (src, dst) trm) in (* TODO evar_map *) let patch_dep = if num_src_hs = num_dst_hs then let patch = shift_by num_src_hs patch in - unshift_by num_src_hs (all_conv_substs env_s evd (src_concl, dst_concl) patch) + unshift_by num_src_hs (snd (all_conv_substs env_s evd (src_concl, dst_concl) patch)) (* TODO evar_map *) else patch in diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index d389245..52c00d0 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -345,8 +345,8 @@ let all_typ_swaps_combs (env : env) (evd : evar_map) (trm : types) : types list equal (snd (map_subterms_env_if_lazy - (fun _ _ _ t -> - isApp t) + (fun _ evd _ t -> + evd, isApp t) (fun en evd _ t -> let swaps = build_swap_map en evd t in let (f, args) = destApp t in @@ -369,7 +369,7 @@ let all_conv_swaps_combs (env : env) (evd : evar_map) (swaps : swap_map) (trm : equal (snd (map_subterms_env_if_lazy - (fun _ _ _ t -> isApp t) + (fun _ evd _ t -> evd, isApp t) (fun en evd depth t -> let swaps = shift_swaps_by depth swaps in let (f, args) = destApp t in From 248fdb9c52096e9438bddc240e26ed4633b259cc Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 19 Aug 2019 14:10:19 -0700 Subject: [PATCH 067/154] Update dependencies --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index a8f5397..cc0b102 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit a8f53976063337db4ecdeb020602323769bfa2e1 +Subproject commit cc0b10294d2393fd91d708a2bc2bf98c8cc779ac diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 47781d0..1d63e2c 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 47781d0097e84873dd3f800b34d5d074a9659aec +Subproject commit 1d63e2c751dd0a46482c932639364e22ac3ed222 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 556a574..4c9b210 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 556a574db3b9e3ba24ac30d9fd1dd45bc45226a4 +Subproject commit 4c9b21051fefd353219ac316eff39fe7171d7e16 From 02297ecff63d7dbc14dae9cc6b33fd24bbb04820 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 19 Aug 2019 14:45:38 -0700 Subject: [PATCH 068/154] Update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index cc0b102..47c8a4e 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit cc0b10294d2393fd91d708a2bc2bf98c8cc779ac +Subproject commit 47c8a4e8398818ce553f085feb643416270a8472 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 1d63e2c..1c7211f 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 1d63e2c751dd0a46482c932639364e22ac3ed222 +Subproject commit 1c7211f6ba9b9b80f58b999005ed709173c4c804 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 4c9b210..6f78c75 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 4c9b21051fefd353219ac316eff39fe7171d7e16 +Subproject commit 6f78c75a3b0fe90aa61e0820673562867c413acf From df9f8e27fa38999b3117adac55f8a9a1713718e4 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 19 Aug 2019 16:30:44 -0700 Subject: [PATCH 069/154] Get building again --- plugin/src/compilation/proofdiff.ml | 18 ++-- .../components/abstraction/abstracters.ml | 21 ++-- .../components/abstraction/abstracters.mli | 5 +- .../components/abstraction/abstraction.ml | 14 ++- .../differencing/appdifferencers.ml | 8 +- .../differencing/changedetectors.ml | 18 ++-- .../differencing/fixdifferencers.ml | 8 +- .../differencing/proofdifferencers.ml | 7 +- .../core/components/factoring/factoring.ml | 12 +-- .../core/components/inversion/inverting.ml | 21 ++-- .../specialization/specialization.ml | 13 +-- plugin/src/core/procedures/search.ml | 7 +- plugin/src/core/procedures/theorem.ml | 2 +- plugin/src/patcher.ml4 | 6 +- plugin/src/representation/assumptions.ml | 95 ++++++++++--------- plugin/src/representation/assumptions.mli | 11 ++- plugin/src/representation/cutlemma.ml | 69 ++++++++------ plugin/src/representation/cutlemma.mli | 13 +-- 18 files changed, 175 insertions(+), 173 deletions(-) diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 28e3a33..d386c35 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -13,19 +13,13 @@ open Declarations open Utilities open Merging open Indutils +open Convertibility (* * Note: Evar discipline here is not good yet, but will change * when we refactor later. *) -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) - (* --- Types --- *) type 'a proof_diff = 'a * 'a * equal_assumptions @@ -237,7 +231,7 @@ let reduced_proof_terms (r : reducer) (d : goal_proof_diff) : env * types * type let (env, ns, os) = merge_diff_closures (dest_goals (proof_to_term d)) [] in let [new_goal_type; new_term] = ns in let [old_goal_type; old_term] = os in - (env, r env Evd.empty old_term, r env Evd.empty new_term) + (env, snd (r env Evd.empty old_term), snd (r env Evd.empty new_term)) (* Get the goal types for a lift goal diff *) let goal_types (d : lift_goal_diff) : types * types = @@ -255,7 +249,7 @@ let reduce_diff (r : reducer) (d : goal_proof_diff) : goal_proof_diff = let (goal_n, _) = new_proof d in let env_o = context_env goal_o in let env_n = context_env goal_n in - eval_with_terms (r env_o Evd.empty o) (r env_n Evd.empty n) d + eval_with_terms (snd (r env_o Evd.empty o)) (snd (r env_n Evd.empty n)) d (* Given a difference in proofs, trim down any casts and get the terms *) let rec reduce_casts (d : goal_proof_diff) : goal_proof_diff = @@ -278,8 +272,8 @@ let reduce_letin (d : goal_proof_diff) : goal_proof_diff = let d_dest = dest_goals d in let ((_, old_env), _) = old_proof d_dest in let ((_, new_env), _) = new_proof d_dest in - let o' = reduce_whd_if_let_in old_env Evd.empty o in - let n' = reduce_whd_if_let_in new_env Evd.empty n in + let o' = snd (reduce_whd_if_let_in old_env Evd.empty o) in + let n' = snd (reduce_whd_if_let_in new_env Evd.empty n) in eval_with_terms o' n' d else d @@ -310,7 +304,7 @@ let update_case_assums (d_ms : (arrow list) proof_diff) : equal_assumptions = (fun assums dst_o dst_n -> let d = difference dst_o dst_n assums in let (env, d_goal, _) = merge_lift_diff_envs d [] in - if convertible env Evd.empty (old_proof d_goal) (new_proof d_goal) then + if snd (convertible env Evd.empty (old_proof d_goal) (new_proof d_goal)) then assume_local_equal assums else shift_assumptions assums) diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 501f7ef..173ebaa 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -8,13 +8,8 @@ open Substitution open Reducers open Filters open Candidates - -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) +open Convertibility +open Stateutils type abstraction_dimension = Arguments | Property type abstracter = env -> evar_map -> types -> types -> candidates -> candidates @@ -78,13 +73,13 @@ let substitute_using (strategy : abstraction_strategy) (env : env) (evd : evar_m (* * Reduce using the reducer in the abstraction strategy *) -let reduce_all_using strategy env evd (cs : candidates) : candidates = +let reduce_all_using strategy env evd (cs : candidates) : candidates state = reduce_all strategy.reducer env evd cs (* * Filter using the filter in the abstraction stragegy *) -let filter_using strategy env evd (goal : types) (cs : candidates) : candidates = +let filter_using strategy env evd (goal : types) (cs : candidates) : candidates state = strategy.filter goal env evd cs (* --- Recover options from an abstraction strategy --- *) @@ -133,11 +128,11 @@ let function_pattern_full_strategy : abstracter = (* A pattern-based full abstraction strategy for constructors *) let pattern_full (env : env) (evd : evar_map) (arg_actual : types) (arg_abstract : types) (trms : types list) : types list = - let types_conv = types_convertible env evd arg_abstract in - let exists_types_conv = List.exists types_conv in + let types_conv trm evd = types_convertible env evd arg_abstract trm in + let exists_types_conv = exists_state types_conv in match map_tuple kind (arg_actual, arg_abstract) with - | (App (f, args), _) when exists_types_conv (Array.to_list args) -> - let arg = List.find types_conv (Array.to_list args) in + | (App (f, args), _) when snd (exists_types_conv (Array.to_list args) evd) -> + let _, arg = find_state types_conv (Array.to_list args) evd in let sub tr = snd (all_constr_substs env evd f tr) in (* TODO evar_map *) syntactic_full env evd arg arg_abstract (List.map sub trms) | _ -> diff --git a/plugin/src/core/components/abstraction/abstracters.mli b/plugin/src/core/components/abstraction/abstracters.mli index 2eda94c..fcbb74e 100644 --- a/plugin/src/core/components/abstraction/abstracters.mli +++ b/plugin/src/core/components/abstraction/abstracters.mli @@ -4,6 +4,7 @@ open Constr open Environ open Evd open Candidates +open Stateutils type abstraction_dimension = Arguments | Property @@ -24,14 +25,14 @@ val substitute_using : * how to reduce *) val reduce_all_using : - abstraction_strategy -> env -> evar_map -> candidates -> candidates + abstraction_strategy -> env -> evar_map -> candidates -> candidates state (* * Filter candidates, using the abstraction strategy to determine * how to filter *) val filter_using : - abstraction_strategy -> env -> evar_map -> types -> candidates -> candidates + abstraction_strategy -> env -> evar_map -> types -> candidates -> candidates state (* --- Recover options from an abstraction strategy --- *) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index ce58934..709f069 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -19,6 +19,7 @@ open Zooming open Contextutils open Merging open Apputils +open Convertibility (* --- TODO for refactoring without breaking things --- *) @@ -30,9 +31,6 @@ open Apputils let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) (* --- End TODO --- *) @@ -174,14 +172,14 @@ let abstract_with_strategy (config : abstraction_config) strategy : candidates = let evd = config.evd in let (env, args) = opts.concrete in let (env_abs, args_abs) = opts.abstract in - let reduced_cs = reduce_all_using strategy env evd config.cs in + let _, reduced_cs = reduce_all_using strategy env evd config.cs in let shift_concrete = List.map (shift_by (nb_rel env_abs - nb_rel env)) in let args_adj = shift_concrete args in let cs_adj = shift_concrete reduced_cs in let bs = substitute_using strategy env_abs evd args_adj args_abs cs_adj in let lambdas = generalize env_abs evd opts.num_to_abstract bs in Printf.printf "%d abstracted candidates\n" (List.length lambdas); - filter_using strategy env evd opts.goal_type lambdas + snd (filter_using strategy env evd opts.goal_type lambdas) (* * Try to abstract candidates with an ordered list of abstraction strategies @@ -222,7 +220,7 @@ let try_abstract_inductive evd (d : lift_goal_diff) (cs : candidates) : candidat let (env, d_type, cs) = merge_lift_diff_envs d cs in let new_goal_type = new_proof d_type in let old_goal_type = old_proof d_type in - if List.for_all2 (convertible env evd) (unfold_args old_goal_type) (unfold_args new_goal_type) then + if List.for_all2 (fun t1 t2 -> snd (convertible env evd t1 t2)) (unfold_args old_goal_type) (unfold_args new_goal_type) then let config = configure_args env evd d_type cs in let num_new_rels = num_new_bindings snd (dest_lift_goals d) in List.map @@ -247,10 +245,10 @@ let abstract_case (opts : options) evd (d : goal_case_diff) cs : candidates = match get_change opts with | Kindofchange.Hypothesis (_, _) -> let (g_o, g_n) = map_tuple context_term (old_goal, new_proof d_goal) in - filter_by_type (mkProd (Names.Name.Anonymous, g_n, shift g_o)) env evd cs + snd (filter_by_type (mkProd (Names.Name.Anonymous, g_n, shift g_o)) env evd cs) | Kindofchange.InductiveType (_, _) -> cs - | Kindofchange.FixpointCase ((_, _), cut) when are_cut env evd cut cs -> + | Kindofchange.FixpointCase ((_, _), cut) when snd (are_cut env evd cut cs) -> cs | _ -> try_abstract_inductive evd d_goal cs diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index e034793..ee5a5d1 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -74,7 +74,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi | Kindofchange.InductiveType (_, _) -> diff_rec diff_f opts d_f | Kindofchange.FixpointCase ((_, _), cut) -> - let filter_diff_cut diff = filter_diff (filter_cut env evd cut) diff in + let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env evd cut trms)) diff in let fs = filter_diff_cut (diff_rec diff_f opts) d_f in if non_empty fs then fs @@ -87,7 +87,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi (fun args -> if Option.has_some cut then let args_lambdas = List.map (reconstruct_lambda env) args in - filter_applies_cut env evd (Option.get cut) args_lambdas + snd (filter_applies_cut env evd (Option.get cut) args_lambdas) else args) (diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion))) @@ -97,7 +97,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi let new_goal = fst (new_proof d) in let (g_o, g_n) = map_tuple context_term (old_goal, new_goal) in let goal_type = mkProd (Names.Name.Anonymous, g_n, shift g_o) in - let filter_goal = filter_by_type goal_type env evd in + let filter_goal trms = snd (filter_by_type goal_type env evd trms) in let filter_diff_h diff = filter_diff filter_goal diff in let fs = filter_diff_h (diff_rec diff_f opts) d_f in if non_empty fs then @@ -142,7 +142,7 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = f | Kindofchange.FixpointCase ((_, _), cut) -> let env = context_env (fst (old_proof d)) in - let filter_diff_cut diff = filter_diff (filter_cut env evd cut) diff in + let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env evd cut trms)) diff in if non_empty f then f else diff --git a/plugin/src/core/components/differencing/changedetectors.ml b/plugin/src/core/components/differencing/changedetectors.ml index 0390b41..7635eac 100644 --- a/plugin/src/core/components/differencing/changedetectors.ml +++ b/plugin/src/core/components/differencing/changedetectors.ml @@ -11,13 +11,7 @@ open Assumptions open Utilities open Zooming open Contextutils - -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) +open Convertibility (* * If the kind of change is a change in conclusion, then @@ -63,12 +57,12 @@ let find_kind_of_change evd (cut : cut_lemma option) (d : goal_proof_diff) = let goals = goal_types d_goals in let env = context_env (old_proof d_goals) in let r = reduce_remove_identities env evd in - let old_goal = r (fst goals) in - let new_goal = r (snd goals) in + let _, old_goal = r (fst goals) in + let _, new_goal = r (snd goals) in let rec diff env typ_o typ_n = match map_tuple kind (typ_o, typ_n) with | (Prod (n_o, t_o, b_o), Prod (_, t_n, b_n)) -> - if (not (convertible env evd t_o t_n)) then + if (not (snd (convertible env evd t_o t_n))) then let d_typs = difference t_o t_n no_assumptions in if same_shape env d_typs then InductiveType (t_o, t_n) @@ -83,8 +77,8 @@ let find_kind_of_change evd (cut : cut_lemma option) (d : goal_proof_diff) = else let args_o = Array.to_list args_o in let args_n = Array.to_list args_n in - if isConst f_o && isConst f_n && (not (convertible env evd f_o f_n)) then - if List.for_all2 (convertible env evd) args_o args_n then + if isConst f_o && isConst f_n && (not (snd (convertible env evd f_o f_n))) then + if List.for_all2 (fun t1 t2 -> snd (convertible env evd t1 t2)) args_o args_n then if not (Option.has_some cut) then failwith "Must supply cut lemma for change in fixpoint" else diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index 39585a6..337c522 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -50,14 +50,14 @@ let rec get_goal_fix env evd (d : types proof_diff) : candidates = | _ -> let reduce_hd = reduce_unfold_whd env evd in let rec get_goal_reduced d = - let red_old = reduce_hd (old_proof d) in - let red_new = reduce_hd (new_proof d) in + let _, red_old = reduce_hd (old_proof d) in + let _, red_new = reduce_hd (new_proof d) in match map_tuple kind (red_old, red_new) with | (App (f1, args1), App (f2, args2)) when equal f1 f2 -> let d_args = difference args1 args2 no_assumptions in diff_map_flat get_goal_reduced d_args | _ when not (equal red_old red_new) -> - [reduce_unfold env evd (mkProd (Names.Name.Anonymous, red_old, shift red_new))] + [snd (reduce_unfold env evd (mkProd (Names.Name.Anonymous, red_old, shift red_new)))] | _ -> give_up in get_goal_reduced (difference old_term new_term no_assumptions) @@ -108,7 +108,7 @@ let diff_fix_cases env evd (d : types proof_diff) : candidates = List.map (fun t -> mkApp (t, Array.make 1 new_term)) lambdas - in unique equal (reduce_all reduce_term env evd apps) + in unique equal (snd (reduce_all reduce_term env evd apps)) else failwith "Cannot infer goals for generalizing change in definition" | _ -> diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index f304d0e..fe24a99 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -16,6 +16,7 @@ open Names open Zooming open Contextutils open Idutils +open Stateutils (* --- TODO for refactoring without breaking things --- *) @@ -105,7 +106,7 @@ let build_app_candidates env evd opts (from_type : types) (old_term : types) (ne (* otherwise, check containment *) let new_term_shift = shift new_term in let sub tr = snd (all_conv_substs_combs env_b evd (new_term_shift, (mkRel 1)) tr) in (* TODO evar_map *) - filter_not_same old_term_shift env_b evd (sub old_term_shift) + snd (filter_not_same old_term_shift env_b evd (sub old_term_shift)) in List.map (fun b -> reconstruct_lambda_n env_b b (nb_rel env)) bodies with _ -> give_up @@ -153,11 +154,11 @@ let find_difference evd (opts : options) (d : goal_proof_diff) : candidates = in let candidates = build_app_candidates env_merge evd opts from_type old_term new_term in let goal_type = mkProd (Name.Anonymous, new_goal_type, shift old_goal_type) in - let reduced = reduce_all reduce_remove_identities env_merge evd candidates in + let _, reduced = reduce_all reduce_remove_identities env_merge evd candidates in let filter = filter_by_type goal_type env_merge evd in List.map (unshift_local (num_new_rels - 1) num_new_rels) - (filter (if is_ind then filter_ihs env_merge evd reduced else reduced)) + (snd (filter (if is_ind then snd (filter_ihs env_merge evd reduced) else reduced))) (* Determine if two diffs are identical (convertible). *) let no_diff evd opts (d : goal_proof_diff) : bool = diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index 202282a..10054c3 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -10,18 +10,12 @@ open Utilities open Debruijn open Reducers open Contextutils +open Convertibility type factors = (env * types) list open Zooming -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) - (* --- Assumptions for path finding --- *) let assumption : types = mkRel 1 @@ -39,7 +33,7 @@ let apply_assumption (fs : factors) (trm : types) : types = * Check if the term is the assumption (last term in the environment) *) let is_assumption (env : env) (evd : evar_map) (trm : types) : bool = - convertible env evd trm assumption + snd (convertible env evd trm assumption) (* * Assume a term of type typ in an environment @@ -119,7 +113,7 @@ let rec find_path (env : env) (evd : evar_map) (trm : types) : factors = * function. *) let factor_term (env : env) (evd : evar_map) (trm : types) : factors = - let (env_zoomed, trm_zoomed) = zoom_lambda_term env (reduce_term env evd trm) in + let (env_zoomed, trm_zoomed) = zoom_lambda_term env (snd (reduce_term env evd trm)) in let path_body = find_path env_zoomed evd trm_zoomed in List.map (fun (env, body) -> diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 05f184b..9079a41 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -14,7 +14,9 @@ open Factoring open Reducers open Contextutils open Equtils - +open Convertibility +open Stateutils + type inverter = evar_map -> (env * types) -> (env * types) option (* --- TODO for refactoring without breaking things --- *) @@ -27,9 +29,6 @@ type inverter = evar_map -> (env * types) -> (env * types) option let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) (* --- End TODO --- *) @@ -74,8 +73,8 @@ let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_m let rec build_swaps i swap = match map_tuple kind swap with | (App (f_s, args_s), App (f_n, args_n)) -> - let is_swap s = not (fold_tuple equal s) in - let arg_swaps = filter_swaps is_swap (of_arguments args_s args_n) in + let is_swap s evd = evd, not (fold_tuple equal s) in + let _, arg_swaps = filter_swaps is_swap (of_arguments args_s args_n) evd in let swaps = unshift_swaps_by i arg_swaps in merge_swaps (swaps :: (map_swaps (build_swaps i) swaps)) | (Lambda (n_s, t_s, b_s), Lambda (_, t_n, b_n)) -> @@ -85,7 +84,7 @@ let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_m | (_, _) -> no_swaps in - let srcs = List.filter (convertible env evd o) (all_typ_swaps_combs env evd n) in + let _, srcs = filter_state (fun n evd -> convertible env evd o n) (all_typ_swaps_combs env n evd) evd in merge_swaps (List.map (fun s -> build_swaps 0 (s, n)) srcs) (* @@ -157,7 +156,7 @@ let exploit_type_symmetry (env : env) (evd : evar_map) (trm : types) : types lis * as a separate step. *) let invert_factor evd (env, rp) : (env * types) option = - let rp = reduce_term env evd rp in + let _, rp = reduce_term env evd rp in match kind rp with | Lambda (n, old_goal_type, body) -> let env_body = push_rel CRD.(LocalAssum(n, old_goal_type)) env in @@ -166,13 +165,13 @@ let invert_factor evd (env, rp) : (env * types) option = let rp_goal = snd (all_conv_substs env evd (old_goal_type, new_goal_type) rp) in (* TODO evar_map *) let goal_type = mkProd (n, new_goal_type, shift old_goal_type) in let flipped = exploit_type_symmetry env evd rp_goal in - let flipped_wt = filter_by_type goal_type env evd flipped in + let _, flipped_wt = filter_by_type goal_type env evd flipped in if List.length flipped_wt > 0 then Some (env, List.hd flipped_wt) else let swap_map = build_swap_map env evd old_goal_type new_goal_type in - let swapped = all_conv_swaps_combs env evd swap_map rp_goal in - let swapped_wt = filter_by_type goal_type env evd swapped in + let swapped = all_conv_swaps_combs env swap_map rp_goal evd in + let _, swapped_wt = filter_by_type goal_type env evd swapped in if List.length swapped_wt > 0 then Some (env, List.hd swapped_wt) else diff --git a/plugin/src/core/components/specialization/specialization.ml b/plugin/src/core/components/specialization/specialization.ml index d4ad319..70fb824 100644 --- a/plugin/src/core/components/specialization/specialization.ml +++ b/plugin/src/core/components/specialization/specialization.ml @@ -37,30 +37,31 @@ let specialize_using (s : specializer) env evd f args = * This will delta-reduce the function f if necessary. * At the bottom level, it returns betaiota reduction. *) -let rec specialize_body (s : specializer) (env : env) (evd : evar_map) (t : types) : types = +let rec specialize_body (s : specializer) (env : env) (evd : evar_map) (t : types) = match kind t with | Lambda (n, t, b) -> - mkLambda (n, t, specialize_body s (push_rel CRD.(LocalAssum(n, t)) env) evd b) + let evd, b = specialize_body s (push_local (n, t) env) evd b in + evd, mkLambda (n, t, b) | App (f, args) -> let f_body = unwrap_definition env f in - s env evd f_body args + evd, s env evd f_body args | _ -> failwith "Term should be of the form (fun args => f args)" (* Convert a specializer into a reducer by taking arguments *) let specialize_to (args : types array) (s : specializer) : reducer = - fun env evd f -> s env evd f args + fun env evd f -> evd, s env evd f args (* * Convert a specializer into a reducer by taking the function * This only handles a single argument *) let specialize_in (f : types) (s : specializer) : reducer = - fun env evd arg -> s env evd f (Array.make 1 arg) + fun env evd arg -> evd, s env evd f (Array.make 1 arg) (* Convert a reducer into a specializer in the obvious way *) let reducer_to_specializer (r : reducer) : specializer = - fun env evd f args -> r env evd (mkApp (f, args)) + fun env evd f args -> snd (r env evd (mkApp (f, args))) (* --- Defaults --- *) diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index a6c881d..1e681b3 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -17,6 +17,7 @@ open Differencing open Cutlemma open Kindofchange open Evd +open Stateutils (* --- Procedure --- *) @@ -46,7 +47,7 @@ let return_patch opts env evd (patches : types list) : types = let body_reducer = specialize_in (get_app cut) specialize_term in let reduction_condition en evd tr = has_cut_type_strict_sym en evd cut tr in let reducer = reduce_body_if reduction_condition body_reducer in - let specialized = List.map (reducer env evd) patches in + let _, specialized = reduce_all reducer env evd patches in let specialized_fs = List.map (factor_term env evd) specialized in let specialized_fs_terms = flat_map reconstruct_factors specialized_fs in let generalized = @@ -59,13 +60,13 @@ let return_patch opts env evd (patches : types list) : types = specialized_fs_terms) in List.hd generalized (* TODO better failure when none found *) | ConclusionCase (Some cut) -> - let patches = reduce_all remove_unused_hypos env evd patches in + let _, patches = reduce_all remove_unused_hypos env evd patches in let generalized = abstract_with_strategies (configure_cut_args env evd cut patches) in List.hd generalized (* TODO better failure when none found *) | Hypothesis (_, _) -> - let patches = reduce_all remove_unused_hypos env evd patches in + let _, patches = reduce_all remove_unused_hypos env evd patches in List.hd patches | _ -> Printf.printf "%s\n" "SUCCESS"; diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index 9e59ea1..ba3c7d9 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -97,7 +97,7 @@ let rec args_to env evd (f : types) (trm : types) : env * (types array) = let update_theorem env evd (src : types) (dst : types) (trm : types) : types = assert (isConst src && isConst dst); let (env, trm) = zoom_lambda_term env trm in - let trm = reduce_term env evd trm in + let _, trm = reduce_term env evd trm in let (env_args, args) = args_to env evd src trm in let specialize = specialize_using specialize_no_reduce env_args evd in let src_typ = infer_type env_args evd (specialize src args) in diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index cdaef57..f578f5a 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -115,7 +115,7 @@ let invert_patch n env evm patch = let patch env evm n try_invert a search = let reduce = try_reduce reduce_remove_identities in let patch_to_red = search env evm a in - let patch = reduce env evm patch_to_red in + let _, patch = reduce env evm patch_to_red in let prefix = Id.to_string n in ignore (define_term n evm patch false); (if !opt_printpatches then @@ -197,7 +197,7 @@ let specialize n trm : unit = let (evm, env) = Pfedit.get_current_context() in let reducer = specialize_body specialize_term in let evm, def = intern env evm trm in - let specialized = reducer env evm def in + let _, specialized = reducer env evm def in ignore (define_term n evm specialized false) (* Abstract a term by a function or arguments *) @@ -218,7 +218,7 @@ let abstract n trm goal : unit = let rels = List.map (fun i -> i + num_discard) (from_one_to num_args) in let args = Array.map (fun i -> mkRel i) (Array.of_list rels) in let app = mkApp (List.hd abstracted, args) in - let reduced = reduce_term config.env evm app in + let _, reduced = reduce_term config.env evm app in let reconstructed = reconstruct_lambda config.env reduced in ignore (define_term n evm reconstructed false) else diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 52c00d0..582b384 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -9,6 +9,8 @@ open Hofs open Printing open Contextutils open Envutils +open Convertibility +open Stateutils (* For now, these are lists of pairs of ints, each int representing an index in a different environment; this representation @@ -22,13 +24,6 @@ let no_assumptions = [] let no_substitutions = [] let no_swaps = [] -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) - (* --- Auxiliary functions on assumptions --- *) (* Print a list of substitutions for debugging purposes *) @@ -240,8 +235,8 @@ let unique_swaps (swaps : swap_map) : swap_map = (* * Filter a swap map by a relation on a pair of types *) -let filter_swaps (p : (types * types) -> bool) (swaps : swap_map) : swap_map = - List.filter p swaps +let filter_swaps (p : (types * types) -> evar_map -> bool state) (swaps : swap_map) = + filter_state p swaps (* * Build a swap map from two arrays of arguments @@ -294,66 +289,76 @@ let shift_swaps = shift_swaps_by 1 (* * Get a swap map for all combinations of a function application *) -let build_swap_map (en : env) (evd : evar_map) (t : types) : swap_map = +let build_swap_map env (t : types) = match kind t with | App (_, args) -> filter_swaps - (fun (a1, a2) -> - (not (convertible en evd a1 a2)) && types_convertible en evd a1 a2) + (branch_state + (fun (a1, a2) sigma -> convertible env sigma a1 a2) + (fun _ -> ret false) (* convertible *) + (branch_state + (fun (a1, a2) sigma -> types_convertible env sigma a1 a2) + (fun _ -> ret true) (* (not convertible) && types_convertible *) + (fun _ -> ret false))) (* not types_convertible *) (combinations_of_arguments args) | _ -> - no_swaps + ret no_swaps (* * Given a pair of arguments to swap, apply the swap inside of args *) -let swap_args (env : env) (evd : evar_map) (args : types array) ((a1, a2) : types * types) = - combine_cartesian_append - (Array.map - (fun a -> - if convertible env evd a1 a then - [a2] - else if convertible env evd a2 a then - [a1] - else - [a]) +let swap_args (env : env) (args : types array) ((a1, a2) : types * types) = + bind + (map_state_array + (branch_state + (fun a sigma -> convertible env sigma a1 a) + (fun _ -> ret [a2]) + (branch_state + (fun a sigma -> convertible env sigma a2 a) + (fun _ -> ret [a1]) + (fun a -> ret [a]))) args) + (fun l -> ret (combine_cartesian_append l)) (* * Apply a swap map to an array of arguments *) -let apply_swaps env evd args swaps : (types array) list = - List.flatten (map_swaps (swap_args env evd args) swaps) +let apply_swaps env args swaps = + bind + (map_state (swap_args env args) swaps) + flatten_state (* * Apply a swap map to an array of arguments, * then combine the results using the combinator c, using a as a default *) -let apply_swaps_combine c a env evd args swaps : 'a list = - let swapped = apply_swaps env evd args swaps in - if List.length swapped = 0 then - [a] - else - a :: List.map c swapped +let apply_swaps_combine c a env args swaps = + bind + (apply_swaps env args swaps) + (fun swapped -> (* TODO is evar_map OK here in both cases? *) + if List.length swapped = 0 then + ret [a] + else + ret (a :: List.map c swapped)) (* In env, swap all arguments to a function * with convertible types with each other, building a swap map for each * term *) -let all_typ_swaps_combs (env : env) (evd : evar_map) (trm : types) : types list = +let all_typ_swaps_combs (env : env) (trm : types) sigma : types list = unique equal (snd (map_subterms_env_if_lazy - (fun _ evd _ t -> - evd, isApp t) - (fun en evd _ t -> - let swaps = build_swap_map en evd t in + (fun _ sigma _ t -> + sigma, isApp t) + (fun en sigma _ t -> + let sigma, swaps = build_swap_map en t sigma in let (f, args) = destApp t in - evd, apply_swaps_combine (fun s -> mkApp (f, s)) t env evd args swaps) + apply_swaps_combine (fun s -> mkApp (f, s)) t env args swaps sigma) (fun _ -> ()) env - evd + sigma () trm)) @@ -364,20 +369,20 @@ let all_typ_swaps_combs (env : env) (evd : evar_map) (trm : types) : types list * This checks convertibility before recursing, and so will replace at * the highest level possible. *) -let all_conv_swaps_combs (env : env) (evd : evar_map) (swaps : swap_map) (trm : types) = +let all_conv_swaps_combs (env : env) (swaps : swap_map) (trm : types) sigma = unique equal (snd (map_subterms_env_if_lazy - (fun _ evd _ t -> evd, isApp t) - (fun en evd depth t -> + (fun _ sigma _ t -> sigma, isApp t) + (fun en sigma depth t -> let swaps = shift_swaps_by depth swaps in let (f, args) = destApp t in - evd, unique - equal - (apply_swaps_combine (fun s -> mkApp (f, s)) t env evd args swaps)) + Util.on_snd + (unique equal) + (apply_swaps_combine (fun s -> mkApp (f, s)) t env args swaps sigma)) (fun depth -> depth + 1) env - evd + sigma 0 trm)) diff --git a/plugin/src/representation/assumptions.mli b/plugin/src/representation/assumptions.mli index 2d4eae7..700b8ff 100644 --- a/plugin/src/representation/assumptions.mli +++ b/plugin/src/representation/assumptions.mli @@ -3,6 +3,7 @@ open Constr open Environ open Evd +open Stateutils type equal_assumptions type param_substitutions @@ -156,7 +157,11 @@ val unique_swaps : swap_map -> swap_map (* * Filter a swap map by a relation on a pair of types *) -val filter_swaps : ((types * types) -> bool) -> swap_map -> swap_map +val filter_swaps : + ((types * types) -> evar_map -> bool state) -> + swap_map -> + evar_map -> + swap_map state (* * Map a function on two types along a swap map and return a list @@ -207,7 +212,7 @@ val shift_swaps : swap_map -> swap_map * This checks convertibility after recursing, and so will replace at * the lowest level possible. *) -val all_conv_swaps_combs : env -> evar_map -> swap_map -> types -> types list +val all_conv_swaps_combs : env -> swap_map -> types -> evar_map -> types list (* * In an environment, swaps all subterms with types convertible to the source @@ -216,4 +221,4 @@ val all_conv_swaps_combs : env -> evar_map -> swap_map -> types -> types list * This checks convertibility after recursing, and so will replace at * the lowest level possible. *) -val all_typ_swaps_combs : env -> evar_map -> types -> types list +val all_typ_swaps_combs : env -> types -> evar_map -> types list diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index 6873c2b..d3c8e1a 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -9,6 +9,8 @@ open Utilities open Typehofs open Contextutils open Envutils +open Convertibility +open Stateutils (* --- TODO for refactoring without breaking things --- *) @@ -21,13 +23,9 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in j_type jmt -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -let concls_convertible env sigma t1 t2 = snd (Convertibility.concls_convertible env sigma t1 t2) - (* --- End TODO --- *) + type cut_lemma = { lemma : types; @@ -46,18 +44,20 @@ let get_app (cut : cut_lemma) = cut.app (* Test if a type is exactly the type of the lemma to cut by *) -let is_cut_strict env evd lemma typ = +let is_cut_strict env sigma lemma typ = try - concls_convertible env evd (reduce_term env evd lemma) (reduce_term env evd typ) + let sigma, lemma = reduce_term env sigma lemma in + let sigma, typ = reduce_term env sigma typ in + concls_convertible env sigma lemma typ with _ -> - false + sigma, false (* Test if a term has exactly the type of the lemma to cut by *) -let has_cut_type_strict env evd cut trm = +let has_cut_type_strict env sigma cut trm = try (* TODO do we need red type here or not? same everywhere *) - on_red_type_default (fun env evd -> is_cut_strict env evd (get_lemma cut)) env evd trm + on_red_type_default (fun env sigma -> is_cut_strict env sigma (get_lemma cut)) env sigma trm with _ -> - false + sigma, false (* Flip the conclusions of a cut lemma *) let rec flip_concls lemma = @@ -80,34 +80,44 @@ let has_cut_type_strict_rev env evd cut trm = try on_red_type_default (fun env evd -> is_cut_strict env evd (flip_concls (get_lemma cut))) env evd trm with _ -> - false + evd, false (* Test if a term has the type of the lemma or its reverse *) let has_cut_type_strict_sym env evd cut trm = - has_cut_type_strict env evd cut trm || has_cut_type_strict_rev env evd cut trm + branch_state + (fun trm sigma -> has_cut_type_strict env sigma cut trm) + (fun _ -> ret true) + (fun trm sigma -> has_cut_type_strict_rev env sigma cut trm) + trm + evd (* Check if a type is loosely the cut lemma (can have extra hypotheses) *) -let rec is_cut env evd lemma typ = +let rec is_cut env sigma lemma typ = match map_tuple kind (lemma, typ) with | (Prod (nl, tl, bl), Prod (nt, tt, bt)) -> if not (isProd bl || isProd bt) then - is_cut_strict env evd lemma typ + is_cut_strict env sigma lemma typ else - if convertible env evd tl tt then - is_cut (push_rel CRD.(LocalAssum(nl, tl)) env) evd bl bt - else - let cut_l = is_cut (push_rel CRD.(LocalAssum(nl, tl)) env) evd bl (shift typ) in - let cut_r = is_cut (push_rel CRD.(LocalAssum(nt, tt)) env) evd (shift lemma) bt in - cut_l || cut_r + branch_state + (fun tt sigma -> convertible env sigma tl tt) + (fun _ sigma -> is_cut (push_rel CRD.(LocalAssum(nl, tl)) env) sigma bl bt) + (fun _ -> + branch_state + (fun bl sigma -> is_cut (push_rel CRD.(LocalAssum(nl, tl)) env) sigma bl (shift typ)) + (fun _ -> ret true) + (fun _ sigma -> is_cut (push_rel CRD.(LocalAssum(nt, tt)) env) sigma (shift lemma) bt) + bl) + tt + sigma | _ -> - false + sigma, false (* Check if a term has loosely the cut lemma type (can have extra hypotheses) *) let has_cut_type env evd cut trm = try on_red_type_default (fun env evd -> is_cut env evd (get_lemma cut)) env evd trm with _ -> - false + evd, false (* Check if a term is loosely an application of the lemma to cut by *) let has_cut_type_app env evd cut trm = @@ -115,11 +125,11 @@ let has_cut_type_app env evd cut trm = let evd, typ = on_red_type_default (fun env evd trm -> evd, shift trm) env evd trm in let env_cut = push_rel CRD.(LocalAssum(Names.Name.Anonymous, get_lemma cut)) env in let app = get_app cut in - let app_app = reduce_term env_cut Evd.empty (mkApp (app, Array.make 1 (mkRel 1))) in + let evd, app_app = reduce_term env_cut Evd.empty (mkApp (app, Array.make 1 (mkRel 1))) in let app_app_typ = infer_type env_cut evd app_app in is_cut env_cut evd app_app_typ typ with _ -> - false + evd, false (* Check if a term is consistent with the cut type *) let consistent_with_cut env cut trm = @@ -135,11 +145,11 @@ let consistent_with_cut env cut trm = (* Filter a list of terms to those with the (loose) cut lemma type *) let filter_cut env evd cut trms = - List.filter (has_cut_type env evd cut) trms + filter_state (fun trm evd -> has_cut_type env evd cut trm) trms evd (* Filter a list of terms to those that apply the (loose) cut lemma type *) let filter_applies_cut env evd cut trms = - List.filter (has_cut_type_app env evd cut) trms + filter_state (fun trm evd -> has_cut_type_app env evd cut trm) trms evd (* * Filter a list of terms to those that are consistent with the cut type @@ -159,4 +169,7 @@ let filter_consistent_cut env cut trms = (* This returns true when the candidates we have patch the lemma we cut by *) let are_cut env evd cut cs = - List.length (filter_cut env evd cut cs) = List.length cs + bind + (fun evd -> filter_cut env evd cut cs) + (fun trms -> ret (List.length trms = List.length cs)) + evd diff --git a/plugin/src/representation/cutlemma.mli b/plugin/src/representation/cutlemma.mli index faed2ec..28bfcfd 100644 --- a/plugin/src/representation/cutlemma.mli +++ b/plugin/src/representation/cutlemma.mli @@ -3,6 +3,7 @@ open Constr open Environ open Evd +open Stateutils (* * Cut lemmas are guidance that the user can provide to help guide search @@ -33,30 +34,30 @@ val get_app : cut_lemma -> types * Test if a term has exactly the type of the lemma to cut by * This term cannot have extra hypotheses *) -val has_cut_type_strict : env -> evar_map -> cut_lemma -> types -> bool +val has_cut_type_strict : env -> evar_map -> cut_lemma -> types -> bool state (* * Test if a term has exactly the type of the lemma to cut by in reverse * This term cannot have extra hypotheses *) -val has_cut_type_strict_rev : env -> evar_map -> cut_lemma -> types -> bool +val has_cut_type_strict_rev : env -> evar_map -> cut_lemma -> types -> bool state (* * Test if a term has the type of the lemma or its reverse *) -val has_cut_type_strict_sym : env -> evar_map -> cut_lemma -> types -> bool +val has_cut_type_strict_sym : env -> evar_map -> cut_lemma -> types -> bool state (* * Filter a list of terms to those that have the cut lemma type * These terms can have extra hypotheses *) -val filter_cut : env -> evar_map -> cut_lemma -> types list -> types list +val filter_cut : env -> evar_map -> cut_lemma -> types list -> (types list) state (* * Filter a list of terms to those that apply the cut lemma type * These terms can have extra hypotheses *) -val filter_applies_cut : env -> evar_map -> cut_lemma -> types list -> types list +val filter_applies_cut : env -> evar_map -> cut_lemma -> types list -> (types list) state (* * Filter a list of terms to those that are consistent with the cut type @@ -68,4 +69,4 @@ val filter_consistent_cut : env -> cut_lemma -> types list -> types list (* * This returns true when the candidates we have patch the lemma we cut by *) -val are_cut : env -> evar_map -> cut_lemma -> types list -> bool +val are_cut : env -> evar_map -> cut_lemma -> types list -> bool state From 14d11975f40df189fabbf28a8e3f3582e4272c71 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 19 Aug 2019 16:39:56 -0700 Subject: [PATCH 070/154] Evar_map practice in assumptions --- .../core/components/inversion/inverting.ml | 4 +- plugin/src/representation/assumptions.ml | 62 +++++++++---------- plugin/src/representation/assumptions.mli | 5 +- plugin/test.sh | 8 +++ 4 files changed, 43 insertions(+), 36 deletions(-) create mode 100755 plugin/test.sh diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 9079a41..1d71434 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -84,7 +84,7 @@ let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_m | (_, _) -> no_swaps in - let _, srcs = filter_state (fun n evd -> convertible env evd o n) (all_typ_swaps_combs env n evd) evd in + let _, srcs = filter_state (fun n evd -> convertible env evd o n) (snd (all_typ_swaps_combs env n evd)) evd in merge_swaps (List.map (fun s -> build_swaps 0 (s, n)) srcs) (* @@ -170,7 +170,7 @@ let invert_factor evd (env, rp) : (env * types) option = Some (env, List.hd flipped_wt) else let swap_map = build_swap_map env evd old_goal_type new_goal_type in - let swapped = all_conv_swaps_combs env swap_map rp_goal evd in + let _, swapped = all_conv_swaps_combs env swap_map rp_goal evd in let _, swapped_wt = filter_by_type goal_type env evd swapped in if List.length swapped_wt > 0 then Some (env, List.hd swapped_wt) diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 582b384..09640ad 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -345,22 +345,21 @@ let apply_swaps_combine c a env args swaps = * with convertible types with each other, building a swap map for each * term *) -let all_typ_swaps_combs (env : env) (trm : types) sigma : types list = - unique - equal - (snd - (map_subterms_env_if_lazy - (fun _ sigma _ t -> - sigma, isApp t) - (fun en sigma _ t -> - let sigma, swaps = build_swap_map en t sigma in - let (f, args) = destApp t in - apply_swaps_combine (fun s -> mkApp (f, s)) t env args swaps sigma) - (fun _ -> ()) - env - sigma - () - trm)) +let all_typ_swaps_combs (env : env) (trm : types) sigma = + Util.on_snd + (unique equal) + (map_subterms_env_if_lazy + (fun _ sigma _ t -> + sigma, isApp t) + (fun en sigma _ t -> + let sigma, swaps = build_swap_map en t sigma in + let (f, args) = destApp t in + apply_swaps_combine (fun s -> mkApp (f, s)) t env args swaps sigma) + (fun _ -> ()) + env + sigma + () + trm) (* * In an environment, swaps all subterms convertible to the source @@ -370,19 +369,18 @@ let all_typ_swaps_combs (env : env) (trm : types) sigma : types list = * the highest level possible. *) let all_conv_swaps_combs (env : env) (swaps : swap_map) (trm : types) sigma = - unique - equal - (snd - (map_subterms_env_if_lazy - (fun _ sigma _ t -> sigma, isApp t) - (fun en sigma depth t -> - let swaps = shift_swaps_by depth swaps in - let (f, args) = destApp t in - Util.on_snd - (unique equal) - (apply_swaps_combine (fun s -> mkApp (f, s)) t env args swaps sigma)) - (fun depth -> depth + 1) - env - sigma - 0 - trm)) + Util.on_snd + (unique equal) + (map_subterms_env_if_lazy + (fun _ sigma _ t -> sigma, isApp t) + (fun en sigma depth t -> + let swaps = shift_swaps_by depth swaps in + let (f, args) = destApp t in + Util.on_snd + (unique equal) + (apply_swaps_combine (fun s -> mkApp (f, s)) t env args swaps sigma)) + shift_i + env + sigma + 0 + trm) diff --git a/plugin/src/representation/assumptions.mli b/plugin/src/representation/assumptions.mli index 700b8ff..8cb30fe 100644 --- a/plugin/src/representation/assumptions.mli +++ b/plugin/src/representation/assumptions.mli @@ -212,7 +212,8 @@ val shift_swaps : swap_map -> swap_map * This checks convertibility after recursing, and so will replace at * the lowest level possible. *) -val all_conv_swaps_combs : env -> swap_map -> types -> evar_map -> types list +val all_conv_swaps_combs : + env -> swap_map -> types -> evar_map -> (types list) state (* * In an environment, swaps all subterms with types convertible to the source @@ -221,4 +222,4 @@ val all_conv_swaps_combs : env -> swap_map -> types -> evar_map -> types list * This checks convertibility after recursing, and so will replace at * the lowest level possible. *) -val all_typ_swaps_combs : env -> types -> evar_map -> types list +val all_typ_swaps_combs : env -> types -> evar_map -> (types list) state diff --git a/plugin/test.sh b/plugin/test.sh new file mode 100755 index 0000000..3908e63 --- /dev/null +++ b/plugin/test.sh @@ -0,0 +1,8 @@ +#!/usr/bin/env bash +coqc coq/Regress.v +coqc coq/Variants.v > ~/foo.txt +coqc coq/Abstract.v +coqc coq/divide.v +coqc coq/Induction.v +coqc coq/IntegersNew.v +coqc coq/Optimization.v From f3fd5e7ffb4a90059d125d3c8eb7aa2a678569d5 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Mon, 19 Aug 2019 17:13:22 -0700 Subject: [PATCH 071/154] evar_map practice in cutlemma.ml --- .../components/abstraction/abstraction.ml | 2 +- .../differencing/appdifferencers.ml | 6 +- plugin/src/core/procedures/search.ml | 2 +- plugin/src/representation/cutlemma.ml | 107 ++++++++++-------- plugin/src/representation/cutlemma.mli | 21 ++-- 5 files changed, 78 insertions(+), 60 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 709f069..b38c868 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -248,7 +248,7 @@ let abstract_case (opts : options) evd (d : goal_case_diff) cs : candidates = snd (filter_by_type (mkProd (Names.Name.Anonymous, g_n, shift g_o)) env evd cs) | Kindofchange.InductiveType (_, _) -> cs - | Kindofchange.FixpointCase ((_, _), cut) when snd (are_cut env evd cut cs) -> + | Kindofchange.FixpointCase ((_, _), cut) when snd (are_cut env cut cs evd) -> cs | _ -> try_abstract_inductive evd d_goal cs diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index ee5a5d1..7070fde 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -74,7 +74,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi | Kindofchange.InductiveType (_, _) -> diff_rec diff_f opts d_f | Kindofchange.FixpointCase ((_, _), cut) -> - let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env evd cut trms)) diff in + let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in let fs = filter_diff_cut (diff_rec diff_f opts) d_f in if non_empty fs then fs @@ -87,7 +87,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi (fun args -> if Option.has_some cut then let args_lambdas = List.map (reconstruct_lambda env) args in - snd (filter_applies_cut env evd (Option.get cut) args_lambdas) + snd (filter_applies_cut env (Option.get cut) args_lambdas evd) else args) (diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion))) @@ -142,7 +142,7 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = f | Kindofchange.FixpointCase ((_, _), cut) -> let env = context_env (fst (old_proof d)) in - let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env evd cut trms)) diff in + let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in if non_empty f then f else diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index 1e681b3..4410890 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -45,7 +45,7 @@ let return_patch opts env evd (patches : types list) : types = match get_change opts with | FixpointCase ((old_type, new_type), cut) -> let body_reducer = specialize_in (get_app cut) specialize_term in - let reduction_condition en evd tr = has_cut_type_strict_sym en evd cut tr in + let reduction_condition en evd tr = has_cut_type_strict_sym en cut tr evd in let reducer = reduce_body_if reduction_condition body_reducer in let _, specialized = reduce_all reducer env evd patches in let specialized_fs = List.map (factor_term env evd) specialized in diff --git a/plugin/src/representation/cutlemma.ml b/plugin/src/representation/cutlemma.ml index d3c8e1a..145a2c2 100644 --- a/plugin/src/representation/cutlemma.ml +++ b/plugin/src/representation/cutlemma.ml @@ -11,20 +11,24 @@ open Contextutils open Envutils open Convertibility open Stateutils +open Inference -(* --- TODO for refactoring without breaking things --- *) +(* --- TODO temporary for refactor: should use this order in lib at some point --- *) -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = - let jmt = Typeops.infer env trm in - j_type jmt +let on_red_type_default f env trm sigma = + Typehofs.on_red_type_default + (fun env sigma trm -> f env trm sigma) + env + sigma + trm -(* --- End TODO --- *) +let reduce_term env trm sigma = + reduce_term env sigma trm +let infer_type env trm sigma = + infer_type env sigma trm + +(* --- End TODO --- *) type cut_lemma = { @@ -44,20 +48,23 @@ let get_app (cut : cut_lemma) = cut.app (* Test if a type is exactly the type of the lemma to cut by *) -let is_cut_strict env sigma lemma typ = +let is_cut_strict env lemma typ sigma = try - let sigma, lemma = reduce_term env sigma lemma in - let sigma, typ = reduce_term env sigma typ in + let sigma, lemma = reduce_term env lemma sigma in + let sigma, typ = reduce_term env typ sigma in concls_convertible env sigma lemma typ with _ -> sigma, false (* Test if a term has exactly the type of the lemma to cut by *) -let has_cut_type_strict env sigma cut trm = +let has_cut_type_strict env cut trm = try (* TODO do we need red type here or not? same everywhere *) - on_red_type_default (fun env sigma -> is_cut_strict env sigma (get_lemma cut)) env sigma trm + on_red_type_default + (fun env -> is_cut_strict env (get_lemma cut)) + env + trm with _ -> - sigma, false + ret false (* Flip the conclusions of a cut lemma *) let rec flip_concls lemma = @@ -76,60 +83,65 @@ let rec flip_concls lemma = * Determine which one to use based on search goals, direction, options, * and candidates. *) -let has_cut_type_strict_rev env evd cut trm = +let has_cut_type_strict_rev env cut trm = try - on_red_type_default (fun env evd -> is_cut_strict env evd (flip_concls (get_lemma cut))) env evd trm + on_red_type_default + (fun env -> is_cut_strict env (flip_concls (get_lemma cut))) + env + trm with _ -> - evd, false + ret false (* Test if a term has the type of the lemma or its reverse *) -let has_cut_type_strict_sym env evd cut trm = +let has_cut_type_strict_sym env cut trm = branch_state - (fun trm sigma -> has_cut_type_strict env sigma cut trm) + (has_cut_type_strict env cut) (fun _ -> ret true) - (fun trm sigma -> has_cut_type_strict_rev env sigma cut trm) + (has_cut_type_strict_rev env cut) trm - evd (* Check if a type is loosely the cut lemma (can have extra hypotheses) *) -let rec is_cut env sigma lemma typ = +let rec is_cut env lemma typ = match map_tuple kind (lemma, typ) with | (Prod (nl, tl, bl), Prod (nt, tt, bt)) -> if not (isProd bl || isProd bt) then - is_cut_strict env sigma lemma typ + is_cut_strict env lemma typ else branch_state (fun tt sigma -> convertible env sigma tl tt) - (fun _ sigma -> is_cut (push_rel CRD.(LocalAssum(nl, tl)) env) sigma bl bt) + (fun _ -> is_cut (push_local (nl, tl) env) bl bt) (fun _ -> branch_state - (fun bl sigma -> is_cut (push_rel CRD.(LocalAssum(nl, tl)) env) sigma bl (shift typ)) + (fun bl -> is_cut (push_local (nl, tl) env) bl (shift typ)) (fun _ -> ret true) - (fun _ sigma -> is_cut (push_rel CRD.(LocalAssum(nt, tt)) env) sigma (shift lemma) bt) + (fun _ -> is_cut (push_local (nt, tt) env) (shift lemma) bt) bl) tt - sigma | _ -> - sigma, false + ret false (* Check if a term has loosely the cut lemma type (can have extra hypotheses) *) -let has_cut_type env evd cut trm = +let has_cut_type env cut trm = try - on_red_type_default (fun env evd -> is_cut env evd (get_lemma cut)) env evd trm + on_red_type_default (fun env -> is_cut env (get_lemma cut)) env trm with _ -> - evd, false + ret false (* Check if a term is loosely an application of the lemma to cut by *) -let has_cut_type_app env evd cut trm = +let has_cut_type_app env cut trm = try - let evd, typ = on_red_type_default (fun env evd trm -> evd, shift trm) env evd trm in - let env_cut = push_rel CRD.(LocalAssum(Names.Name.Anonymous, get_lemma cut)) env in - let app = get_app cut in - let evd, app_app = reduce_term env_cut Evd.empty (mkApp (app, Array.make 1 (mkRel 1))) in - let app_app_typ = infer_type env_cut evd app_app in - is_cut env_cut evd app_app_typ typ + let env_cut = push_local (Names.Name.Anonymous, get_lemma cut) env in + bind + (on_red_type_default (fun _ trm -> ret (shift trm)) env trm) + (fun typ -> + bind + (reduce_term env_cut (mkApp (get_app cut, Array.make 1 (mkRel 1)))) + (fun app_app -> + bind + (infer_type env_cut app_app) + (fun app_app_typ -> is_cut env_cut app_app_typ typ))) with _ -> - evd, false + ret false (* Check if a term is consistent with the cut type *) let consistent_with_cut env cut trm = @@ -144,12 +156,12 @@ let consistent_with_cut env cut trm = in consistent env (get_lemma cut) trm (* Filter a list of terms to those with the (loose) cut lemma type *) -let filter_cut env evd cut trms = - filter_state (fun trm evd -> has_cut_type env evd cut trm) trms evd +let filter_cut env cut trms = + filter_state (has_cut_type env cut) trms (* Filter a list of terms to those that apply the (loose) cut lemma type *) -let filter_applies_cut env evd cut trms = - filter_state (fun trm evd -> has_cut_type_app env evd cut trm) trms evd +let filter_applies_cut env cut trms = + filter_state (has_cut_type_app env cut) trms (* * Filter a list of terms to those that are consistent with the cut type @@ -168,8 +180,7 @@ let filter_consistent_cut env cut trms = (List.filter (consistent_with_cut env cut) trms) (* This returns true when the candidates we have patch the lemma we cut by *) -let are_cut env evd cut cs = +let are_cut env cut cs = bind - (fun evd -> filter_cut env evd cut cs) + (filter_cut env cut cs) (fun trms -> ret (List.length trms = List.length cs)) - evd diff --git a/plugin/src/representation/cutlemma.mli b/plugin/src/representation/cutlemma.mli index 28bfcfd..a2bf7c7 100644 --- a/plugin/src/representation/cutlemma.mli +++ b/plugin/src/representation/cutlemma.mli @@ -34,39 +34,46 @@ val get_app : cut_lemma -> types * Test if a term has exactly the type of the lemma to cut by * This term cannot have extra hypotheses *) -val has_cut_type_strict : env -> evar_map -> cut_lemma -> types -> bool state +val has_cut_type_strict : + env -> cut_lemma -> types -> evar_map -> bool state (* * Test if a term has exactly the type of the lemma to cut by in reverse * This term cannot have extra hypotheses *) -val has_cut_type_strict_rev : env -> evar_map -> cut_lemma -> types -> bool state +val has_cut_type_strict_rev : + env -> cut_lemma -> types -> evar_map -> bool state (* * Test if a term has the type of the lemma or its reverse *) -val has_cut_type_strict_sym : env -> evar_map -> cut_lemma -> types -> bool state +val has_cut_type_strict_sym : + env -> cut_lemma -> types -> evar_map -> bool state (* * Filter a list of terms to those that have the cut lemma type * These terms can have extra hypotheses *) -val filter_cut : env -> evar_map -> cut_lemma -> types list -> (types list) state +val filter_cut : + env -> cut_lemma -> types list -> evar_map -> (types list) state (* * Filter a list of terms to those that apply the cut lemma type * These terms can have extra hypotheses *) -val filter_applies_cut : env -> evar_map -> cut_lemma -> types list -> (types list) state +val filter_applies_cut : + env -> cut_lemma -> types list -> evar_map -> (types list) state (* * Filter a list of terms to those that are consistent with the cut type * Offset these terms by the same amount (so return the subterm * that actually can have the cut type). *) -val filter_consistent_cut : env -> cut_lemma -> types list -> types list +val filter_consistent_cut : + env -> cut_lemma -> types list -> types list (* * This returns true when the candidates we have patch the lemma we cut by *) -val are_cut : env -> evar_map -> cut_lemma -> types list -> bool state +val are_cut : + env -> cut_lemma -> types list -> evar_map -> bool state From 648d15140e38b94759b57cdca86564ee7b169e41 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 21 Aug 2019 15:21:42 -0700 Subject: [PATCH 072/154] Update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 47c8a4e..0b42dac 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 47c8a4e8398818ce553f085feb643416270a8472 +Subproject commit 0b42dac4c326e63a7d87c4c52f463797437cee04 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 1c7211f..0c77be1 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 1c7211f6ba9b9b80f58b999005ed709173c4c804 +Subproject commit 0c77be1e84a35b6836f22ece0534939f07eced40 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 6f78c75..f675ffc 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 6f78c75a3b0fe90aa61e0820673562867c413acf +Subproject commit f675ffc82600f9d54b7b46c135799bbcc5b80dcc From cf73169a177f10ddef43054ace519f15770b1ae7 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 21 Aug 2019 17:54:15 -0700 Subject: [PATCH 073/154] WIP adding state --- .../src/representation/categories/category.ml | 54 ++- .../representation/categories/category.mli | 17 +- .../src/representation/categories/proofcat.ml | 368 +++++++++++------- 3 files changed, 267 insertions(+), 172 deletions(-) diff --git a/plugin/src/representation/categories/category.ml b/plugin/src/representation/categories/category.ml index 63a4172..b3b2778 100644 --- a/plugin/src/representation/categories/category.ml +++ b/plugin/src/representation/categories/category.ml @@ -1,12 +1,15 @@ -(* A super simple representation for small categories. *) +(* A representation for small categories with state *) +(* Will go away at some point *) open Utilities +open Stateutils +open Evd module type Opaque = sig type t val as_string : t -> string - val equal : t -> t -> bool + val equal : t -> t -> evar_map -> bool state end module type CatT = @@ -37,19 +40,26 @@ struct type arrow = (obj * morph * obj) type arr = - Identity of obj + | Identity of obj | Composite of arr * arr | Primitive of arrow - let make objects morphisms i t = + let make (objects : Object.t list) morphisms i t = let aux obj l (dom, mor, cod) = - if Object.equal obj dom then ((mor, cod) :: l) else l + branch_state + (Object.equal obj) + (fun _ -> ret ((mor, cod) :: l)) + (fun _ -> ret l) + dom in - let cs = - List.map - (fun obj -> (obj, List.fold_left (aux obj) [] morphisms)) - objects - in Category (cs, i, t) + bind + (map_state + (fun obj -> + bind + (fold_left_state (aux obj) [] morphisms) + (fun ms -> ret (obj, ms))) + objects) + (fun cs -> ret (Category (cs, i, t))) (* Operations about morphisms *) let rec domain f = @@ -77,9 +87,12 @@ struct Identity a let between (Category (cl, _, _)) dom cod = - List.map (fun (mor, _) -> (dom, mor, cod)) - (List.filter (fun (_, obj) -> Object.equal obj cod) - (snd (List.find (fun adj -> Object.equal (fst adj) dom) cl))) + bind + (find_state (fun adj -> Object.equal (fst adj) dom) cl) + (fun adj -> + bind + (filter_state (fun (_, obj) -> Object.equal obj cod) (snd adj)) + (map_state (fun (mor, _) -> ret (dom, mor, cod)))) let objects c = match c with @@ -88,9 +101,14 @@ struct let append_initial_terminal it os = if Option.has_some it then let ito = Option.get it in - if List.exists (fun o -> Object.equal o ito) os then os else ito :: os - else os - in append_initial_terminal t (append_initial_terminal i os) + branch_state + (exists_state (fun o -> Object.equal o ito)) + ret + (fun os -> ret (ito :: os)) + os + else + ret os + in bind (append_initial_terminal i os) (append_initial_terminal t) let morphisms (Category (cs, _, _)) = flat_map (fun (s, adjs) -> (List.map (fun (m, d) -> (s, m, d)) adjs)) cs @@ -102,7 +120,7 @@ struct let morphism_as_string (src, m, dst) = Printf.sprintf "(%s, %s, %s)" (Object.as_string src) (Morphism.as_string m) (Object.as_string dst) - let as_string cat = + let as_string cat sigma = (* For now, string representation for debugging *) (*failwith "TODO: repurpose graphviz serialization"*) let initial_terminal_as_string it = @@ -113,7 +131,7 @@ struct in Printf.sprintf "Objects:\n%s\n\nMorphisms:\n%s\n\nInitial:\n%s\n\nTerminal:\n%s\n" - (String.concat ",\n" (List.map Object.as_string (objects cat))) + (String.concat ",\n" (List.map Object.as_string (snd (objects cat sigma)))) (String.concat ",\n" (List.map morphism_as_string (morphisms cat))) (initial_terminal_as_string (initial cat)) (initial_terminal_as_string (terminal cat)) diff --git a/plugin/src/representation/categories/category.mli b/plugin/src/representation/categories/category.mli index dba8ac3..485c9f7 100644 --- a/plugin/src/representation/categories/category.mli +++ b/plugin/src/representation/categories/category.mli @@ -1,11 +1,14 @@ -(* A super simple interface for small categories. *) -(* TODO clean, given additions of functor and so on *) +(* An interface for small categories with state *) +(* Will go away at some point *) + +open Stateutils +open Evd module type Opaque = sig type t val as_string : t -> string - val equal : t -> t -> bool + val equal : t -> t -> evar_map -> bool state end module type CatT = @@ -29,7 +32,7 @@ sig type obj = Object.t type morph = Morphism.t - val make : obj list -> (obj * morph * obj) list -> obj option -> obj option -> cat + val make : obj list -> (obj * morph * obj) list -> obj option -> obj option -> evar_map -> cat state type arrow = (obj * morph * obj) type arr = @@ -41,13 +44,13 @@ sig val codomain : arr -> obj val compose : arr -> arr -> arr option val identity : obj -> arr - val between : cat -> obj -> obj -> arrow list (* primitive morphisms only *) - val objects : cat -> obj list + val between : cat -> obj -> obj -> evar_map -> (arrow list) state (* primitive morphisms only *) + val objects : cat -> evar_map -> (obj list) state val morphisms : cat -> arrow list (* primitive morpshism only *) val initial : cat -> obj option val terminal : cat -> obj option - val as_string : cat -> string + val as_string : cat -> evar_map -> string end module Functor (Dom : CatT) (Cod : CatT): diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index e1c0526..7be4e50 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -8,18 +8,23 @@ open Printing open Assumptions open Utilities open Merging +open Stateutils (* - * Note: Evar discipline is currently very bad here. But, we will eventually - * get rid of this representation, so it is not worth fixing in the meantime. + * Note: We will soon get rid of this representation. + * It is inefficient and makes the code more difficult to understand. *) -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) +(* --- TODO for refactor: Use this order in lib later --- *) -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) +let convertible env t1 t2 sigma = + Convertibility.convertible env sigma t1 t2 -(* --- End TODO --- *) +let types_convertible env t1 t2 sigma = + Convertibility.types_convertible env sigma t1 t2 + +(* --- End TODO *) + (* --- Type definitions --- *) @@ -49,16 +54,18 @@ struct let as_string (c : t) = match c with - | Context (ctx, i) -> Printf.sprintf "%s [%s]" (ctx_as_string ctx) (string_of_int i) + | Context (ctx, i) -> + Printf.sprintf "%s [%s]" (ctx_as_string ctx) (string_of_int i) (* For now we just trust IDs, later if we want we can change this *) let ctx_equal (ctx1 : type_context) (ctx2 : type_context) = true let equal (c1 : t) (c2 : t) = - let Context (ctx1, i1) = c1 in - let Context (ctx2, i2) = c2 in - (i1 = i2) && (ctx_equal ctx1 ctx2) + ret + (let Context (ctx1, i1) = c1 in + let Context (ctx2, i2) = c2 in + (i1 = i2) && (ctx_equal ctx1 ctx2)) end module Extension = @@ -68,24 +75,29 @@ struct (* Prints an extension edge *) let rec as_string (e : t) = match e with - | AnonymousBinding -> "Anonymous" - | Index i -> Printf.sprintf "(Rel %d)" i - | InductiveHypothesis i -> Printf.sprintf "(IH %d)" i - | LazyBinding (trm, env) -> term_as_string env trm - | AppBinding (e1, e2) -> Printf.sprintf "(%s %s)" (as_string e1) (as_string e2) - - let rec equal (e1 : t) (e2 : t) = + | AnonymousBinding -> + "Anonymous" + | Index i -> + Printf.sprintf "(Rel %d)" i + | InductiveHypothesis i -> + Printf.sprintf "(IH %d)" i + | LazyBinding (trm, env) -> + term_as_string env trm + | AppBinding (e1, e2) -> + Printf.sprintf "(%s %s)" (as_string e1) (as_string e2) + + let rec equal e1 e2 = match (e1, e2) with - | (LazyBinding(trm1, env1), LazyBinding(trm2, env2)) -> + | (LazyBinding (trm1, env1), LazyBinding (trm2, env2)) -> if env1 == env2 then - convertible env1 Evd.empty trm1 trm2 + convertible env1 trm1 trm2 else let (env, trm1s, trm2s) = merge_closures (env1, [trm1]) (env2, [trm2]) no_assumptions in - convertible env Evd.empty (List.hd trm1s) (List.hd trm2s) + convertible env (List.hd trm1s) (List.hd trm2s) | (AppBinding (e11, e21), AppBinding (e12, e22)) -> - equal e11 e12 && equal e12 e22 (* imperfect *) + and_state (equal e11) (equal e21) e12 e22 (* imperfect *) | _ -> - e1 = e2 + ret (e1 = e2) end (* Categories *) @@ -94,7 +106,7 @@ type proof_cat = ProofCat.cat type arrow = ProofCat.arrow (* Initial category *) -let initial_category : proof_cat = +let initial_category : evar_map -> proof_cat state = ProofCat.make [initial_context] [] (Some initial_context) None (* Initial and terminal objects *) @@ -115,79 +127,82 @@ let morphisms = ProofCat.morphisms (* * True iff o1 and o2 are equal *) -let objects_equal (o1 : context_object) (o2 : context_object) : bool = +let objects_equal (o1 : context_object) (o2 : context_object) = TypeContext.equal o1 o2 (* * True iff o1 and o2 are not equal *) -let objects_not_equal (o1 : context_object) (o2 : context_object) : bool = - not (objects_equal o1 o2) +let objects_not_equal (o1 : context_object) (o2 : context_object) = + not_state (objects_equal o1) o2 (* * True iff os contains o *) -let contains_object (o : context_object) (os : context_object list) : bool = - List.exists (objects_equal o) os +let contains_object (o : context_object) (os : context_object list) = + exists_state (objects_equal o) os (* * True iff os doesn't contain o *) -let not_contains_object (o : context_object) (os : context_object list): bool = - not (contains_object o os) +let not_contains_object (o : context_object) (os : context_object list) = + not_state (contains_object o) os (* * True iff e1 and e2 are equal *) -let extensions_equal (e1 : extension) (e2 : extension) : bool = +let extensions_equal (e1 : extension) (e2 : extension) = Extension.equal e1 e2 (* * True iff e1 and e2 are not equal *) -let extensions_not_equal (e1 : extension) (e2 : extension) : bool = - not (extensions_equal e1 e2) +let extensions_not_equal (e1 : extension) (e2 : extension) = + not_state (extensions_equal e1) e2 (* Check if two extensions are equal with a set of assumptions *) -let rec extensions_equal_assums (e1 : extension) (e2 : extension) (assums : equal_assumptions) = +let rec extensions_equal_assums assums (e1 : extension) (e2 : extension) = match (e1, e2) with | (LazyBinding(trm1, env1), LazyBinding(trm2, env2)) -> if env1 == env2 then - convertible env1 Evd.empty trm1 trm2 + convertible env1 trm1 trm2 else let (env, trm1s, trm2s) = merge_closures (env1, [trm1]) (env2, [trm2]) assums in - convertible env Evd.empty (List.hd trm1s) (List.hd trm2s) + convertible env (List.hd trm1s) (List.hd trm2s) | (AppBinding (e11, e21), AppBinding (e12, e22)) -> - extensions_equal_assums e11 e12 assums - && extensions_equal_assums e12 e22 assums (* imperfect *) + and_state (extensions_equal_assums assums e11) (extensions_equal_assums assums e21) e12 e22 (* imperfect *) | _ -> - e1 = e2 + ret (e1 = e2) (* * True iff a1 and a2 are equal *) -let arrows_equal (m1 : arrow) (m2 : arrow) : bool = +let arrows_equal (m1 : arrow) (m2 : arrow) = let (src1, e1, dst1) = m1 in let (src2, e2, dst2) = m2 in - objects_equal src1 src2 && extensions_equal e1 e2 && objects_equal dst1 dst2 + and_state + (objects_equal src1) + (and_state (extensions_equal e1) (objects_equal dst1) e2) + src2 + dst2 (* * True iff a1 and a2 are not equal *) -let arrows_not_equal (m1 : arrow) (m2 : arrow) : bool = - not (arrows_equal m1 m2) +let arrows_not_equal (m1 : arrow) (m2 : arrow) = + not_state (arrows_equal m1) m2 (* * True iff ms contains m *) -let contains_arrow (m : arrow) (ms : arrow list) : bool = - List.exists (arrows_equal m) ms +let contains_arrow (m : arrow) (ms : arrow list) = + exists_state (arrows_equal m) ms (* * True iff ms doesn't contain m *) -let not_contains_arrow (m : arrow) (ms : arrow list) : bool = - not (contains_arrow m ms) +let not_contains_arrow (m : arrow) (ms : arrow list) = + not_state (contains_arrow m) ms (* * Map a function on the source of an arrow @@ -234,13 +249,13 @@ let map_ext_arrow (f : extension -> extension) (m : arrow) : arrow = (* * True iff an arrow m maps from o *) -let maps_from (o : context_object) (m : arrow) : bool = +let maps_from (o : context_object) (m : arrow) = map_source (objects_equal o) m (* * True iff an arrow m maps to o *) -let maps_to (o : context_object) (m : arrow) : bool = +let maps_to (o : context_object) (m : arrow) = map_dest (objects_equal o) m (* @@ -258,55 +273,59 @@ let conclusions (ms : arrow list) : context_object list = (* * Return all objects in os except for the ones that equal except *) -let all_objects_except (except : context_object) (os : context_object list) : context_object list = - List.filter (objects_not_equal except) os +let all_objects_except (except : context_object) (os : context_object list) = + filter_state (objects_not_equal except) os (* * Return all arrows in ms except for the ones that equal except *) -let all_arrows_except (except : arrow) (ms : arrow list) : arrow list = - List.filter (arrows_not_equal except) ms +let all_arrows_except (except : arrow) (ms : arrow list) = + filter_state (arrows_not_equal except) ms (* * Return all objects in os except for the ones in except *) -let all_objects_except_those_in (except : context_object list) (os : context_object list) : context_object list = - List.filter (fun o -> not_contains_object o except) os +let all_objects_except_those_in (except : context_object list) (os : context_object list) = + filter_state (fun o -> not_contains_object o except) os (* * Return all arrows in ms except for the ones in except *) -let all_arrows_except_those_in (except : arrow list) (ms : arrow list) : arrow list = - List.filter (fun o -> not_contains_arrow o except) ms +let all_arrows_except_those_in (except : arrow list) (ms : arrow list) = + filter_state (fun o -> not_contains_arrow o except) ms (* * Return all arrows from ms that start from src *) -let arrows_with_source (src : context_object) (ms : arrow list) : arrow list = - List.filter (maps_from src) ms +let arrows_with_source (src : context_object) (ms : arrow list) = + filter_state (maps_from src) ms (* * Return all arrows from ms that end with dst *) -let arrows_with_dest (dst : context_object) (ms : arrow list) : arrow list = - List.filter (maps_to dst) ms +let arrows_with_dest (dst : context_object) (ms : arrow list) = + filter_state (maps_to dst) ms (* * Combine os1 and os2 into a single list without duplicates *) -let combine_objects (os1 : context_object list) (os2 : context_object list) : context_object list = - List.append os1 (all_objects_except_those_in os1 os2) +let combine_objects (os1 : context_object list) (os2 : context_object list) = + bind + (all_objects_except_those_in os1 os2) + (fun l -> ret (List.append os1 l)) (* * Combine ms1 and ms2 into a single list without duplicates *) -let combine_arrows (ms1 : arrow list) (ms2 : arrow list) : arrow list = - List.append ms1 (all_arrows_except_those_in ms1 ms2) +let combine_arrows (ms1 : arrow list) (ms2 : arrow list) = + bind + (all_arrows_except_those_in ms1 ms2) + (fun l -> ret (List.append ms1 l)) (* * Get all of the objects found in ms *) -let objects_of_arrows (ms : arrow list) : context_object list = +let objects_of_arrows (ms : arrow list) = combine_objects (hypotheses ms) (conclusions ms) (* --- Categories --- *) @@ -316,67 +335,73 @@ let initial_opt = ProofCat.initial let terminal_opt = ProofCat.terminal (* Apply a function to the list of objects of c *) -let map_objects (f : context_object list -> 'a) (c : proof_cat) : 'a = - f (objects c) +let map_objects f c = + bind (objects c) f (* Apply a function to the list of arrows of c *) -let map_arrows (f : arrow list -> 'a) (c : proof_cat) : 'a = +let map_arrows f c = f (morphisms c) (* * Destruct c *) -let destruct_cat (c : proof_cat) = - let os = objects c in +let destruct_cat (c : proof_cat) sigma = + let (sigma, os) = objects c sigma in let ms = morphisms c in let i = ProofCat.initial c in let t = ProofCat.terminal c in - (os, ms, i, t) + sigma, (os, ms, i, t) (* * Add an object o to c *) -let add_object (o : context_object) (c : proof_cat) : proof_cat = - let (os, ms, i, t) = destruct_cat c in - make_category (o :: os) ms i t +let add_object (o : context_object) (c : proof_cat) = + bind (destruct_cat c) (fun (os, ms, i, t) -> make_category (o :: os) ms i t) (* * Remove an object o from c *) -let remove_object (o : context_object) (c : proof_cat) : proof_cat = - let (os, ms, i, t) = destruct_cat c in +let remove_object (o : context_object) (c : proof_cat) = let get_it ito = match ito with - | Some it -> if objects_equal it o then None else ito - | None -> None - in make_category (all_objects_except o os) ms (get_it i) (get_it t) + | Some it -> + branch_state (objects_equal it) (fun _ -> ret None) (fun _ -> ret ito) o + | None -> + ret None + in + bind + (destruct_cat c) + (fun (os, ms, i, t) -> + bind + (all_objects_except o os) + (fun os' -> + bind + (get_it i) + (fun i' -> bind (get_it t) (make_category os' ms i')))) (* * Add an arrow m to c *) -let add_arrow (m : arrow) (c : proof_cat) : proof_cat = - let (os, ms, i, t) = destruct_cat c in - make_category os (m :: ms) i t +let add_arrow (m : arrow) (c : proof_cat) = + bind (destruct_cat c) (fun (os, ms, i, t) -> make_category os (m :: ms) i t) (* * Set the initial object of c *) -let set_initial (i : initial_object) (c : proof_cat) : proof_cat = - let (os, ms, _, t) = destruct_cat c in - make_category os ms i t +let set_initial (i : initial_object) (c : proof_cat) = + bind (destruct_cat c) (fun (os, ms, _, t) -> make_category os ms i t) (* * Set the terminal object of c *) -let set_terminal (t : terminal_object) (c : proof_cat) : proof_cat = - let (os, ms, i, _) = destruct_cat c in - make_category os ms i t +let set_terminal (t : terminal_object) (c : proof_cat) = + bind (destruct_cat c) (fun (os, ms, i, _) -> make_category os ms i t) (* * Set the initial and terminal objects of c *) -let set_initial_terminal (i : initial_object) (t : terminal_object) (c : proof_cat) : proof_cat = - set_terminal t (set_initial i c) +let set_initial_terminal (i : initial_object) (t : terminal_object) (c : proof_cat) = + bind (set_initial i c) (set_terminal t) (* * Check whether c has an initial object @@ -407,30 +432,39 @@ let terminal (c : proof_cat) : context_object = (* * Check whether o is initial in c *) -let is_initial (c : proof_cat) (o : context_object) : bool = - has_initial c && objects_equal o (initial c) +let is_initial (c : proof_cat) (o : context_object) = + and_state + (fun c -> ret (has_initial c)) + (fun c -> objects_equal o (initial c)) + c + c (* * Check whether o is terminal in c *) -let is_terminal (c : proof_cat) (o : context_object) : bool = - has_terminal c && objects_equal o (terminal c) +let is_terminal (c : proof_cat) (o : context_object) = + and_state + (fun c -> ret (has_terminal c)) + (fun c -> objects_equal o (terminal c)) + c + c (* * Combine c1 and c2, setting i as the initial object * and t as the terminal object *) -let combine (i : initial_object) (t : terminal_object) (c1 : proof_cat) (c2 : proof_cat) : proof_cat = - let (os1, os2) = (objects c1, objects c2) in - let (ms1, ms2) = (morphisms c1, morphisms c2) in - let os = combine_objects os1 os2 in - let ms = combine_arrows ms1 ms2 in - ProofCat.make os ms i t +let combine (i : initial_object) (t : terminal_object) (c1 : proof_cat) (c2 : proof_cat) sigma = + let (ms1, ms2) = map_tuple morphisms (c1, c2) in + let sigma, os1 = objects c1 sigma in + let sigma, os2 = objects c2 sigma in + let sigma, os = combine_objects os1 os2 sigma in + let sigma, ms = combine_arrows ms1 ms2 sigma in + ProofCat.make os ms i t sigma (* Check if c contains m *) -let category_contains_arrow (a : arrow) (c : proof_cat) : bool = +let category_contains_arrow (a : arrow) (c : proof_cat) sigma = let ms = morphisms c in - contains_arrow a ms + contains_arrow a ms sigma (* Get the only explicit arrow in c, or fail if it doesn't have one *) let only_arrow (c : proof_cat) : arrow = @@ -439,37 +473,46 @@ let only_arrow (c : proof_cat) : arrow = List.hd ms (* Determine if o is a hypothesis in c *) -let is_hypothesis (c : proof_cat) (o : context_object) : bool = +let is_hypothesis (c : proof_cat) (o : context_object) = contains_object o (map_arrows hypotheses c) (* Determine if o is not a hypothesis in c *) -let is_not_hypothesis (c : proof_cat) (o : context_object) : bool = - not (is_hypothesis c o) +let is_not_hypothesis (c : proof_cat) (o : context_object) = + not_state (is_hypothesis c) o (* --- Paths of explicit (not transitive or identity) arrows --- *) (* * Check if src reaches dst via some explicit path in c *) -let has_path (c : proof_cat) (src : context_object) (dst : context_object) : bool = +let has_path (c : proof_cat) (src : context_object) (dst : context_object) = let rec reaches ms (s : context_object) (d : context_object) = - map_if_else - (always_true) - (fun d' -> - let reaches_rec = fun s' -> reaches ms s' d' in - let adj = arrows_with_source s ms in - non_empty adj && List.exists id (List.map (map_dest reaches_rec) adj)) - (objects_equal s d) - d + branch_state + (objects_equal d) + (fun _ -> ret true) + (fun s -> + bind + (arrows_with_source s ms) + (fun adj -> + and_state + (fun adj -> ret (non_empty adj)) + (fun adj -> + bind + (map_state (map_dest (reaches ms s)) adj) + (exists_state (fun s -> ret (id s)))) + adj + adj)) + s in reaches (morphisms c) src dst (* * Get a list of arrows on some path starting from o in c *) -let arrows_from (c : proof_cat) (o : context_object) : arrow list = - let rec from ms s = - let adj = arrows_with_source s ms in - List.append adj (flat_map (map_dest (from ms)) adj) +let arrows_from (c : proof_cat) (o : context_object) = + let rec from ms s sigma = + let sigma, adj = arrows_with_source s ms sigma in + let sigma, tl = flat_map_state (map_dest (from ms)) adj sigma in + sigma, List.append adj tl in from (morphisms c) o (* @@ -477,39 +520,68 @@ let arrows_from (c : proof_cat) (o : context_object) : arrow list = * Assumes there are no cycles * Maintains order for lists *) -let arrows_between (c : proof_cat) (src : context_object) (dst : context_object) : arrow list = - let rec between ms s d = - map_if_else - (fun _ -> []) - (fun d' -> - let between_rec = fun s' -> between ms s' d' in - let adj = arrows_with_source s ms in - List.append adj (flat_map (map_dest between_rec) adj)) - (objects_equal s d) - d +let arrows_between (c : proof_cat) (src : context_object) (dst : context_object)sigma = + + let rec reaches ms (s : context_object) (d : context_object) = + branch_state + (objects_equal d) + (fun _ -> ret true) + (fun s -> + bind + (arrows_with_source s ms) + (fun adj -> + and_state + (fun adj -> ret (non_empty adj)) + (fun adj -> + bind + (map_state (map_dest (reaches ms s)) adj) + (exists_state (fun s -> ret (id s)))) + adj + adj)) + s + in + +let rec between ms s d = + branch_state + (objects_equal d) + (fun _ -> ret []) + (fun s -> + bind + (arrows_with_source s ms) + (fun adj sigma -> + let sigma, tl = flat_map_state (map_dest (between ms s)) adj sigma in + sigma, List.append adj tl)) + s in let ms = morphisms c in - if has_path c src dst then - between ms src dst - else if has_path c dst src then - between ms dst src - else - [] + branch_state + (has_path c src) + (between ms src) + (fun _ -> + branch_state + (has_path c dst) + (between ms dst) + (fun _ -> ret []) + src) + dst (* * Find ordered paths from src in c via explicit arrows *) -let paths_from (c : proof_cat) (src : context_object) : arrow list list = +let paths_from (c : proof_cat) (src : context_object) = let rec paths ms s = - let adj = arrows_with_source s ms in - flat_map - (fun m -> - let paths = map_dest (paths ms) m in - if (List.length paths) = 0 then - [[m]] - else - List.map (fun p -> m :: p) paths) - adj + bind + (arrows_with_source s ms) + (flat_map_state + (fun m -> + bind + (map_dest (paths ms) m) + (fun paths -> + ret + (if (List.length paths) = 0 then + [[m]] + else + List.map (fun p -> m :: p) paths)))) in paths (morphisms c) src (* @@ -517,10 +589,12 @@ let paths_from (c : proof_cat) (src : context_object) : arrow list list = * If dst is the initial context, this is 0 * Error if no initial context * Error if dst is unreachable + * TODO left off here *) -let shortest_path_length (c : proof_cat) (o : context_object) : int = +let shortest_path_length (c : proof_cat) (o : context_object) sigma : int = let i = initial c in - assert (has_path c i o); + let sigma, has_path_bool = has_path c i o sigma in + assert has_path_bool; let is_o = objects_equal o in let contains_o = contains_object o in map_if_else From 71595cb8a5935be7a53b6ec4fa29c6aeafcdcee3 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Sun, 25 Aug 2019 20:18:39 -0700 Subject: [PATCH 074/154] A bit more work on the old category representation --- .../src/representation/categories/category.ml | 30 ++++--- .../representation/categories/category.mli | 14 ++-- .../src/representation/categories/proofcat.ml | 73 +++++++++-------- .../representation/categories/proofcat.mli | 81 ++++++++++--------- 4 files changed, 103 insertions(+), 95 deletions(-) diff --git a/plugin/src/representation/categories/category.ml b/plugin/src/representation/categories/category.ml index b3b2778..baf0f04 100644 --- a/plugin/src/representation/categories/category.ml +++ b/plugin/src/representation/categories/category.ml @@ -1,5 +1,5 @@ (* A representation for small categories with state *) -(* Will go away at some point *) +(* Will go away at some point soon (not bothering to clean!) *) open Utilities open Stateutils @@ -19,9 +19,9 @@ sig type cat type arrow = (obj * morph * obj) - val objects : cat -> obj list + val objects : cat -> evar_map -> (obj list) state val morphisms : cat -> arrow list - val make : obj list -> arrow list -> obj option -> obj option -> cat + val make : obj list -> arrow list -> obj option -> obj option -> evar_map -> cat state val initial : cat -> obj option val terminal : cat -> obj option end @@ -140,14 +140,20 @@ end module Functor (Dom : CatT) (Cod : CatT) = struct - type f_obj = Dom.obj -> Cod.obj + type f_obj = Dom.obj -> evar_map -> Cod.obj state type f_arr = Dom.arrow -> Cod.arrow - type f_iterm = Dom.obj option -> Cod.obj option + type f_iterm = Dom.obj option -> evar_map -> (Cod.obj option) state type t = Fun of f_obj * f_arr * f_iterm * f_iterm let make (f_o : f_obj) (f_a : f_arr) = - let f_it = Option.map f_o in - Fun (f_o, f_a, f_it, f_it) + let f_it : f_iterm = + fun o sigma -> + match Option.map (fun o -> f_o o sigma) o with + | Some (sigma, o') -> + ret (Some o') sigma + | None -> + ret None sigma + in ret (Fun (f_o, f_a, f_it, f_it)) let make_with_it (f_o : f_obj) (f_a : f_arr) (f_i : f_iterm) (f_t : f_iterm) = Fun (f_o, f_a, f_i, f_t) @@ -164,14 +170,14 @@ struct let f_T (f : t) = match f with Fun (_, _, _, f_t) -> f_t - let apply (f : t) (c : Dom.cat) = + let apply (f : t) (c : Dom.cat) sigma = let f_o = f_O f in let f_a = f_A f in - let os = List.map f_o (Dom.objects c) in + let sigma, os = bind (Dom.objects c) (map_state f_o) sigma in let ms = List.map f_a (Dom.morphisms c) in - let i = (f_I f) (Dom.initial c) in - let t = (f_T f) (Dom.terminal c) in - Cod.make os ms i t + let sigma, i = (f_I f) (Dom.initial c) sigma in + let sigma, t = (f_T f) (Dom.terminal c) sigma in + Cod.make os ms i t sigma let as_string (f : t) = failwith "TODO" diff --git a/plugin/src/representation/categories/category.mli b/plugin/src/representation/categories/category.mli index 485c9f7..9096ccc 100644 --- a/plugin/src/representation/categories/category.mli +++ b/plugin/src/representation/categories/category.mli @@ -1,5 +1,5 @@ (* An interface for small categories with state *) -(* Will go away at some point *) +(* Will go away at some point soon (not bothering to clean!) *) open Stateutils open Evd @@ -18,9 +18,9 @@ sig type cat type arrow = (obj * morph * obj) - val objects : cat -> obj list + val objects : cat -> evar_map -> (obj list) state val morphisms : cat -> arrow list - val make : obj list -> arrow list -> obj option -> obj option -> cat + val make : obj list -> arrow list -> obj option -> obj option -> evar_map -> cat state val initial : cat -> obj option val terminal : cat -> obj option end @@ -55,18 +55,18 @@ end module Functor (Dom : CatT) (Cod : CatT): sig - type f_obj = Dom.obj -> Cod.obj + type f_obj = Dom.obj -> evar_map -> Cod.obj state type f_arr = Dom.arrow -> Cod.arrow - type f_iterm = Dom.obj option -> Cod.obj option + type f_iterm = Dom.obj option -> evar_map -> (Cod.obj option) state type t = Fun of f_obj * f_arr * f_iterm * f_iterm - val make : f_obj -> f_arr -> t + val make : f_obj -> f_arr -> evar_map -> t state val make_with_it : f_obj -> f_arr -> f_iterm -> f_iterm -> t val f_O : t -> f_obj val f_A : t -> f_arr val f_I : t -> f_iterm val f_T : t -> f_iterm - val apply : t -> Dom.cat -> Cod.cat + val apply : t -> Dom.cat -> evar_map -> Cod.cat state val as_string : t -> string end diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index 7be4e50..9fa07aa 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -521,26 +521,6 @@ let arrows_from (c : proof_cat) (o : context_object) = * Maintains order for lists *) let arrows_between (c : proof_cat) (src : context_object) (dst : context_object)sigma = - - let rec reaches ms (s : context_object) (d : context_object) = - branch_state - (objects_equal d) - (fun _ -> ret true) - (fun s -> - bind - (arrows_with_source s ms) - (fun adj -> - and_state - (fun adj -> ret (non_empty adj)) - (fun adj -> - bind - (map_state (map_dest (reaches ms s)) adj) - (exists_state (fun s -> ret (id s)))) - adj - adj)) - s - in - let rec between ms s d = branch_state (objects_equal d) @@ -584,31 +564,49 @@ let paths_from (c : proof_cat) (src : context_object) = List.map (fun p -> m :: p) paths)))) in paths (morphisms c) src +(* + * TODO move to lib if we still need this after refactor to remove cats + *) +let find_off (a : 'a list) (p : 'a -> evar_map -> bool state) sigma : int state = + let rec find_rec a p n = + match a with + | [] -> failwith "not found" + | h :: tl -> + branch_state + p + (fun _ -> ret n) + (fun _ -> find_rec tl p (n + 1)) + h + in find_rec a p 0 sigma + (* * Get the length of the shortest path from the initial context to dst * If dst is the initial context, this is 0 * Error if no initial context * Error if dst is unreachable - * TODO left off here *) -let shortest_path_length (c : proof_cat) (o : context_object) sigma : int = +let shortest_path_length (c : proof_cat) (o : context_object) sigma : int state = let i = initial c in let sigma, has_path_bool = has_path c i o sigma in assert has_path_bool; - let is_o = objects_equal o in - let contains_o = contains_object o in - map_if_else - (fun _ -> 0) - (fun s -> - let pdsts = List.map conclusions (paths_from c s) in - let pdsts_with_o = List.filter contains_o pdsts in - let lengths_to_o = - List.map - (fun path -> find_off path is_o + 1) + branch_state + (objects_equal o) + (fun _ -> ret 0) + (fun s sigma -> + let sigma, paths = paths_from c s sigma in + let pdsts = List.map conclusions paths in + let sigma, pdsts_with_o = filter_state (contains_object o) pdsts sigma in + let sigma, lengths_to_o = + map_state + (fun path -> + bind + (find_off path (objects_equal o)) + (fun n -> ret (n + 1))) pdsts_with_o - in List.hd (List.sort Pervasives.compare lengths_to_o)) - (is_o i) + sigma + in sigma, List.hd (List.sort Pervasives.compare lengths_to_o)) i + sigma (* --- Functors --- *) @@ -617,7 +615,8 @@ module ProofFunctor = Functor (ProofCat) (ProofCat) (* * Apply a functor over proof categories *) -let apply_functor (fo : context_object -> context_object) (fa : arrow -> arrow) (c : proof_cat) = - let f = ProofFunctor.make fo fa in - ProofFunctor.apply f c +let apply_functor fo fa (c : proof_cat) = + bind + (ProofFunctor.make fo fa) + (fun f -> ret (ProofFunctor.apply f c)) diff --git a/plugin/src/representation/categories/proofcat.mli b/plugin/src/representation/categories/proofcat.mli index c4052bf..c8b7802 100644 --- a/plugin/src/representation/categories/proofcat.mli +++ b/plugin/src/representation/categories/proofcat.mli @@ -1,6 +1,8 @@ open Constr open Environ open Assumptions +open Evd +open Stateutils (* Proof categories, core logic *) @@ -19,7 +21,7 @@ type proof_cat type arrow = context_object * extension * context_object (* Initial category *) -val initial_category : proof_cat +val initial_category : evar_map -> proof_cat state (* Initial and terminal objects *) type initial_object = context_object option @@ -34,14 +36,14 @@ val context_as_string : context_object -> string val extension_as_string : extension -> string (* Get a proof category as a string *) -val proof_as_string : proof_cat -> string +val proof_as_string : proof_cat -> evar_map -> string (* --- Objects, extensions, and arrows --- *) (* * Get the objects of a proof category *) -val objects : proof_cat -> context_object list +val objects : proof_cat -> evar_map -> (context_object list) state (* * Get the arrows of a proof category @@ -51,57 +53,57 @@ val morphisms : proof_cat -> arrow list (* * True iff two objects are equal *) -val objects_equal : context_object -> context_object -> bool +val objects_equal : context_object -> context_object -> evar_map -> bool state (* * True iff two objects are not equal *) -val objects_not_equal : context_object -> context_object -> bool +val objects_not_equal : context_object -> context_object -> evar_map -> bool state (* * True iff the list of objects contains the object *) -val contains_object : context_object -> context_object list -> bool +val contains_object : context_object -> context_object list -> evar_map -> bool state (* * True iff the list of objects doesn't contain the object *) -val not_contains_object : context_object -> context_object list -> bool +val not_contains_object : context_object -> context_object list -> evar_map -> bool state (* * True iff two extensions are equal *) -val extensions_equal : extension -> extension -> bool +val extensions_equal : extension -> extension -> evar_map -> bool state (* * True iff two extensions are not equal *) -val extensions_not_equal : extension -> extension -> bool +val extensions_not_equal : extension -> extension -> evar_map -> bool state (* * True iff two extensions are equal with a set of assumptions *) -val extensions_equal_assums : extension -> extension -> equal_assumptions -> bool +val extensions_equal_assums : equal_assumptions -> extension -> extension -> evar_map -> bool state (* * True iff two arrows are equal *) -val arrows_equal : arrow -> arrow -> bool +val arrows_equal : arrow -> arrow -> evar_map -> bool state (* * True iff two arrows are not equal *) -val arrows_not_equal : arrow -> arrow -> bool +val arrows_not_equal : arrow -> arrow -> evar_map -> bool state (* * True iff the list of arrows contains the arrow *) -val contains_arrow : arrow -> arrow list -> bool +val contains_arrow : arrow -> arrow list -> evar_map -> bool state (* * True iff the list of arrows doesn't contain the arrow *) -val not_contains_arrow : arrow -> arrow list -> bool +val not_contains_arrow : arrow -> arrow list -> evar_map -> bool state (* * Map a function on the source of an arrow @@ -136,12 +138,12 @@ val map_ext_arrow : (extension -> extension) -> arrow -> arrow (* * True iff an arrow maps from the provided object *) -val maps_from : context_object -> arrow -> bool +val maps_from : context_object -> arrow -> evar_map -> bool state (* * True iff an arrow maps to the provided object *) -val maps_to : context_object -> arrow -> bool +val maps_to : context_object -> arrow -> evar_map -> bool state (* * Return all objects from which an arrow flows @@ -156,47 +158,47 @@ val conclusions : arrow list -> context_object list (* * Return all objects in a list except for the ones that equal a given object *) -val all_objects_except : context_object -> context_object list -> context_object list +val all_objects_except : context_object -> context_object list -> evar_map -> (context_object list) state (* * Return all arrows in a list except for the ones that equal a given arrow *) -val all_arrows_except : arrow -> arrow list -> arrow list +val all_arrows_except : arrow -> arrow list -> evar_map -> (arrow list) state (* * Return all objects in a list except for the ones in another list *) -val all_objects_except_those_in : context_object list -> context_object list -> context_object list +val all_objects_except_those_in : context_object list -> context_object list -> evar_map -> (context_object list) state (* * Return all arrows in a list except for the ones in another list *) -val all_arrows_except_those_in : arrow list -> arrow list -> arrow list +val all_arrows_except_those_in : arrow list -> arrow list -> evar_map -> (arrow list) state (* * Return all arrows from a list that start from a source object *) -val arrows_with_source : context_object -> arrow list -> arrow list +val arrows_with_source : context_object -> arrow list -> evar_map -> (arrow list) state (* * Return all arrows from a list that end with a destination object *) -val arrows_with_dest : context_object -> arrow list -> arrow list +val arrows_with_dest : context_object -> arrow list -> evar_map -> (arrow list) state (* * Combine two lists of objects into a single list without duplicates *) -val combine_objects : context_object list -> context_object list -> context_object list +val combine_objects : context_object list -> context_object list -> evar_map -> (context_object list) state (* * Combine two lists of arrows into a single list without duplicates *) -val combine_arrows : arrow list -> arrow list -> arrow list +val combine_arrows : arrow list -> arrow list -> evar_map -> (arrow list) state (* * Get all of the objects found in a list of arrows *) -val objects_of_arrows : arrow list -> context_object list +val objects_of_arrows : arrow list -> evar_map -> (context_object list) state (* --- Categories --- *) @@ -208,22 +210,23 @@ val make_category : arrow list -> initial_object -> terminal_object -> - proof_cat + evar_map -> + proof_cat state (* * Add an object to a category *) -val add_object : context_object -> proof_cat -> proof_cat +val add_object : context_object -> proof_cat -> evar_map -> proof_cat state (* * Remove an object from a category *) -val remove_object : context_object -> proof_cat -> proof_cat +val remove_object : context_object -> proof_cat -> evar_map -> proof_cat state (* * Add an arrow to a category *) -val add_arrow : arrow -> proof_cat -> proof_cat +val add_arrow : arrow -> proof_cat -> evar_map -> proof_cat state (* * Check if a category has an initial object @@ -238,27 +241,27 @@ val has_terminal : proof_cat -> bool (* * Check whether an object is initial in the category *) -val is_initial : proof_cat -> context_object -> bool +val is_initial : proof_cat -> context_object -> evar_map -> bool state (* * Check whether an object is terminal in the category *) -val is_terminal : proof_cat -> context_object -> bool +val is_terminal : proof_cat -> context_object -> evar_map -> bool state (* * Set the initial object of a category *) -val set_initial : initial_object -> proof_cat -> proof_cat +val set_initial : initial_object -> proof_cat -> evar_map -> proof_cat state (* * Set the terminal object of a category *) -val set_terminal : terminal_object -> proof_cat -> proof_cat +val set_terminal : terminal_object -> proof_cat -> evar_map -> proof_cat state (* * Set the initial and terminal objects of a category *) -val set_initial_terminal : initial_object -> terminal_object -> proof_cat -> proof_cat +val set_initial_terminal : initial_object -> terminal_object -> proof_cat -> evar_map -> proof_cat state (* * Get the initial object of a category, if it exists @@ -283,10 +286,10 @@ val terminal : proof_cat -> context_object (* * Combine two proof categories, setting the initial and terminal objects *) -val combine : initial_object -> terminal_object -> proof_cat -> proof_cat -> proof_cat +val combine : initial_object -> terminal_object -> proof_cat -> proof_cat -> evar_map -> proof_cat state (* Check if a category contains an arrow *) -val category_contains_arrow : arrow -> proof_cat -> bool +val category_contains_arrow : arrow -> proof_cat -> evar_map -> bool state (* * Get the only arrow in a category @@ -296,13 +299,13 @@ val category_contains_arrow : arrow -> proof_cat -> bool val only_arrow : proof_cat -> arrow (* Determine if an object is a hypothesis in a proof category *) -val is_hypothesis : proof_cat -> context_object -> bool +val is_hypothesis : proof_cat -> context_object -> evar_map -> bool state (* Determine if an object is not a hypothesis in a proof category *) -val is_not_hypothesis : proof_cat -> context_object -> bool +val is_not_hypothesis : proof_cat -> context_object -> evar_map -> bool state (* Apply a function to the list of objects of c *) -val map_objects : (context_object list -> 'a) -> proof_cat -> 'a +val map_objects : (context_object list -> 'a) -> proof_cat -> evar_map -> 'a state (* Apply a function to the list of arrows of c *) val map_arrows : (arrow list -> 'a) -> proof_cat -> 'a From 0f9b65dac6e2fe9a83059b5437e6f45875f50102 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 27 Aug 2019 16:32:19 -0700 Subject: [PATCH 075/154] Finish proofcat.ml temporary porting --- plugin/src/representation/categories/proofcat.ml | 4 ++-- .../src/representation/categories/proofcat.mli | 16 +++++++++------- 2 files changed, 11 insertions(+), 9 deletions(-) diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index 9fa07aa..a93631e 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -520,7 +520,7 @@ let arrows_from (c : proof_cat) (o : context_object) = * Assumes there are no cycles * Maintains order for lists *) -let arrows_between (c : proof_cat) (src : context_object) (dst : context_object)sigma = +let arrows_between (c : proof_cat) (src : context_object) (dst : context_object) = let rec between ms s d = branch_state (objects_equal d) @@ -618,5 +618,5 @@ module ProofFunctor = Functor (ProofCat) (ProofCat) let apply_functor fo fa (c : proof_cat) = bind (ProofFunctor.make fo fa) - (fun f -> ret (ProofFunctor.apply f c)) + (fun f -> ProofFunctor.apply f c) diff --git a/plugin/src/representation/categories/proofcat.mli b/plugin/src/representation/categories/proofcat.mli index c8b7802..47d7f84 100644 --- a/plugin/src/representation/categories/proofcat.mli +++ b/plugin/src/representation/categories/proofcat.mli @@ -5,6 +5,7 @@ open Evd open Stateutils (* Proof categories, core logic *) +(* Will go away soon *) (* --- Type definitions --- *) @@ -305,7 +306,7 @@ val is_hypothesis : proof_cat -> context_object -> evar_map -> bool state val is_not_hypothesis : proof_cat -> context_object -> evar_map -> bool state (* Apply a function to the list of objects of c *) -val map_objects : (context_object list -> 'a) -> proof_cat -> evar_map -> 'a state +val map_objects : (context_object list -> evar_map -> 'a state) -> proof_cat -> evar_map -> 'a state (* Apply a function to the list of arrows of c *) val map_arrows : (arrow list -> 'a) -> proof_cat -> 'a @@ -317,19 +318,19 @@ val map_arrows : (arrow list -> 'a) -> proof_cat -> 'a * If this path is a list, then this maintains order * Assumes there are no cycles *) -val arrows_from : proof_cat -> context_object -> arrow list +val arrows_from : proof_cat -> context_object -> evar_map -> (arrow list) state (* * Get a list of explicit arrows on some path between two objects in a category * If this path is a list, then this maintains order * Assumes there are no cycles *) -val arrows_between : proof_cat -> context_object -> context_object -> arrow list +val arrows_between : proof_cat -> context_object -> context_object -> evar_map -> (arrow list) state (* * Find ordered paths from an object via explicit arrows *) -val paths_from : proof_cat -> context_object -> arrow list list +val paths_from : proof_cat -> context_object -> evar_map -> (arrow list list) state (* * Get the length of the shortest path from the initial object to an object @@ -337,7 +338,7 @@ val paths_from : proof_cat -> context_object -> arrow list list * Error if no initial object * Error if the object is unreachable *) -val shortest_path_length : proof_cat -> context_object -> int +val shortest_path_length : proof_cat -> context_object -> evar_map -> int state (* --- Functors --- *) @@ -345,7 +346,8 @@ val shortest_path_length : proof_cat -> context_object -> int * Apply a functor over proof categories *) val apply_functor : - (context_object -> context_object) -> + (context_object -> evar_map -> context_object state) -> (arrow -> arrow) -> proof_cat -> - proof_cat + evar_map -> + proof_cat state From 9ee77394a6cc08fbaa0b2f89f7fa610eb224bae3 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 10:50:54 -0700 Subject: [PATCH 076/154] Attempt at true refactor (semantics preserving) --- .../src/compilation/categories/catzooming.ml | 9 +- plugin/src/compilation/evaluation.ml | 4 +- plugin/src/compilation/expansion.ml | 47 +++--- .../categories/proofcatterms.ml | 146 ++++++++++-------- 4 files changed, 112 insertions(+), 94 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index 83381c5..9678773 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -1,3 +1,4 @@ +open Stateutils open Proofcat open Environ open Proofdiff @@ -25,10 +26,10 @@ type 'a zoomer = let remove_initial (c : proof_cat) : proof_cat = let i = initial c in let ms = morphisms c in - let os' = all_objects_except i (objects c) in - let (ms', ims) = List.partition (map_source (objects_not_equal i)) ms in + let _, os' = all_objects_except i (snd (objects c Evd.empty)) Evd.empty in + let (ms', ims) = List.partition (map_source (fun o -> snd (objects_not_equal i o Evd.empty))) ms in let (_, _, i') = List.hd ims in - make_category os' ms' (Some i') (terminal_opt c) + snd (make_category os' ms' (Some i') (terminal_opt c) Evd.empty) (* Remove the first n contexts *) let rec remove_first_n (n : int) (c : proof_cat) : proof_cat = @@ -101,7 +102,7 @@ let intro_params nparams d = (List.fold_right2 (fun (_, e1, _) (_, e2, _) d_opt -> let d = Option.get d_opt in - if extensions_equal_assums e1 e2 (assumptions d) then + if snd (extensions_equal_assums (assumptions d) e1 e2 Evd.empty) then intro_common d else intro d) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 1f2b239..1927911 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -36,7 +36,7 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = *) let eval_theorem_bind (e : extension) (env : env) (typ : types) : proof_cat = let t = Context (Term (typ, env), (fid ())) in - let c = set_terminal (Some t) (add_object t initial_category) in + let _, c = set_terminal (Some t) (snd (add_object t (snd (initial_category Evd.empty)) Evd.empty)) Evd.empty in bind c (initial_context, e, t) (* Evaluate an anonymous proof of typ one step *) @@ -130,7 +130,7 @@ let bind_constrs_to_args fc cs ncs arg_partition = *) let combine_constrs (default : proof_cat) (cs : proof_cat list) : proof_cat = match cs with - | h :: t -> List.fold_left (combine (initial_opt h) None) h t + | h :: t -> List.fold_left (fun c1 c2 -> snd (combine (initial_opt h) None c1 c2 Evd.empty)) h t | [] -> default (* diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index addcdd3..a8bcf30 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -1,5 +1,6 @@ (* Expanding proof categories *) +open Stateutils open Names open Environ open Evd @@ -72,9 +73,9 @@ let expand_inductive (env : env) (((i, ii), u) : pinductive) : proof_cat = let cs = List.map (eval_proof env_ind) constrs in List.fold_left (fun cind c -> - let os = (terminal c) :: (objects cind) in + let os = (terminal c) :: (snd (objects cind Evd.empty)) in let ms = List.append (morphisms c) (morphisms cind) in - make_category os ms (initial_opt cind) None) + snd (make_category os ms (initial_opt cind) None Evd.empty)) (List.hd cs) (List.tl cs) @@ -143,7 +144,7 @@ let expand_terminal (c : proof_cat) : proof_cat = match t with | Context (Term (trm, env), i) -> let ms = morphisms c in - let concls = arrows_with_dest t ms in + let _, concls = arrows_with_dest t ms Evd.empty in let binding = if non_empty concls then let (_, ext, _) = List.hd concls in (* arbitrary for now *) @@ -164,7 +165,7 @@ let expand_terminal (c : proof_cat) : proof_cat = *) let partition_expandable (c : proof_cat) : (arrow list * arrow list) = List.partition - (map_dest (fun o -> context_is_product o && is_not_hypothesis c o)) + (map_dest (fun o -> context_is_product o && snd (is_not_hypothesis c o Evd.empty))) (morphisms c) (* @@ -175,12 +176,12 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = List.map (fun (s, e, d) -> let dc = expand_product_fully d in - let map_i_to_src m = if (objects_equal (initial dc) m) then s else m in + let map_i_to_src m = if (snd (objects_equal (initial dc) m Evd.empty)) then s else m in let arity = (List.length (morphisms dc)) - 1 in bind_apply_function (shift_ext_by arity (substitute_ext_env (context_env (terminal dc)) e)) arity - (apply_functor map_i_to_src (map_source_arrow map_i_to_src) dc)) + (snd (apply_functor (fun o -> ret (map_i_to_src o)) (map_source_arrow map_i_to_src) dc Evd.empty))) ms (* @@ -194,15 +195,15 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = * inductive types. *) let expand_inductive_conclusions_fully (c : proof_cat) : proof_cat = - let c_os = objects c in + let _, c_os = objects c Evd.empty in let (ms_to_expand, old_ms) = partition_expandable c in - let old_os = all_objects_except_those_in (conclusions ms_to_expand) c_os in + let _, old_os = all_objects_except_those_in (conclusions ms_to_expand) c_os Evd.empty in let expanded = expand_inductive_conclusions ms_to_expand in - let new_os = flat_map (map_objects (all_objects_except_those_in c_os)) expanded in + let new_os = flat_map (fun os -> snd (map_objects (fun o sigma -> all_objects_except_those_in c_os o sigma) os Evd.empty)) expanded in let new_ms = flat_map morphisms expanded in let os = List.append old_os new_os in let ms = List.append old_ms new_ms in - make_category os ms (initial_opt c) None + snd (make_category os ms (initial_opt c) None Evd.empty) (* For an inductive proof, expand n inductive parameters and the principle P *) let expand_inductive_params (n : int) (c : proof_cat) : proof_cat = @@ -217,8 +218,8 @@ let expand_inductive_params (n : int) (c : proof_cat) : proof_cat = let applies_ih (env : env) (evd : evar_map) (p : types) (c : proof_cat) (o : context_object) : bool = if context_is_app o then let (f, _) = context_as_app o in - let f = unshift_by (shortest_path_length c o) f in - is_hypothesis c o && has_type env evd p f + let f = unshift_by (snd (shortest_path_length c o Evd.empty)) f in + snd (is_hypothesis c o Evd.empty) && has_type env evd p f else false @@ -233,14 +234,16 @@ let bind_ihs (c : proof_cat) : proof_cat = let env_with_p = context_env (context_at_index c 1) in let (_, _, p) = CRD.to_tuple @@ lookup_rel 1 env_with_p in let env = pop_rel_context 1 env_with_p in - apply_functor - id - (fun m -> - if map_dest (applies_ih env Evd.empty p c) m then - map_ext_arrow (fun _ -> fresh_ih ()) m - else - m) - c + snd + (apply_functor + (fun o -> ret o) + (fun m -> + if map_dest (applies_ih env Evd.empty p c) m then + map_ext_arrow (fun _ -> fresh_ih ()) m + else + m) + c + Evd.empty) (* * Expand an inductive constructor @@ -252,8 +255,8 @@ let expand_constr (c : proof_cat) : proof_cat = let ms = morphisms c_exp in let assums = hypotheses ms in let concls = conclusions ms in - let tr = List.hd (all_objects_except_those_in assums concls) in (*arbitrary*) - make_category (objects c_exp) ms (initial_opt c_exp) (Some tr) + let tr = List.hd (snd (all_objects_except_those_in assums concls Evd.empty)) in (*arbitrary*) + snd (make_category (snd (objects c_exp Evd.empty)) ms (initial_opt c_exp) (Some tr) Evd.empty) (* * Expand the application of a constant function diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 91fd42d..6c608a4 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -7,6 +7,7 @@ open Names open Debruijn open Assumptions open Utilities +open Stateutils module CRD = Context.Rel.Declaration @@ -118,7 +119,7 @@ let unique_common_subpath (paths : arrow list list) : arrow list = (fun l path -> match l with | [] -> path - | _ -> List.filter (fun m -> contains_arrow m path) l) + | _ -> List.filter (fun m -> snd (contains_arrow m path Evd.empty)) l) [] paths @@ -130,7 +131,7 @@ let unique_common_subpath (paths : arrow list list) : arrow list = *) let params_and_prop (c : proof_cat) (npms : int) : arrow list * arrow = let i = initial c in - let paths = paths_from c i in + let _, paths = paths_from c i Evd.empty in if List.length paths = 1 then let path = Array.of_list (List.hd paths) in let subpath = List.rev (List.map (Array.get path) (range 0 (npms + 1))) in @@ -171,8 +172,8 @@ let split (c : proof_cat) : proof_cat list = (fun ms -> let os = i :: (conclusions ms) in let (_, _, t) = List.nth ms (List.length ms - 1) in - make_category os ms (Some i) (Some t)) - (paths_from c i) + snd (make_category os ms (Some i) (Some t) Evd.empty)) + (snd (paths_from c i Evd.empty)) (* --- Transformations on terms and environments --- *) @@ -203,7 +204,7 @@ let closest_ih c (ihs : arrow list) (m : arrow) : context_object * int = List.sort (fun (_, i1) (_, i2) -> Pervasives.compare i1 i2) (List.map - (map_dest (fun d -> (d, List.length (arrows_between c d s)))) + (map_dest (fun d -> (d, List.length (snd (arrows_between c d s Evd.empty))))) ihs) in List.hd ih_proxes @@ -285,16 +286,18 @@ let shift_ext_by (n : int) (e : extension) : extension = (* Map the identifiers of contexts of c with f *) let map_ids (f : int -> int) (c : proof_cat) : proof_cat = - apply_functor - (fun (Context (c, id)) -> - Context (c, f id)) - (fun (Context (s, sid), e, Context (d, did)) -> - (Context (s, f sid), e, Context (d, f did))) - c + snd + (apply_functor + (fun (Context (c, id)) -> + ret (Context (c, f id))) + (fun (Context (s, sid), e, Context (d, did)) -> + (Context (s, f sid), e, Context (d, f did))) + c + Evd.empty) (* Get a map from context identifiers to fresh identifiers *) let get_fresh_ids (c : proof_cat) : (int * int) list = - List.map (fun (Context (_, id)) -> (id, (fid ()))) (objects c) + List.map (fun (Context (_, id)) -> (id, (fid ()))) (snd (objects c Evd.empty)) (* * Make fresh identifiers for every context in c @@ -339,8 +342,8 @@ let rec substitute_ext_env (env : env) (e : extension) : extension = *) let partition_initial_terminal (c : proof_cat) (is_initial : bool) : (context_object list) * arrow * (arrow list) = let i_or_t = map_if_else initial terminal is_initial c in - let os = all_objects_except i_or_t (objects c) in - let maps = map_if_else (maps_from i_or_t) (maps_to i_or_t) is_initial in + let _, os = all_objects_except i_or_t (snd (objects c Evd.empty)) Evd.empty in + let maps = map_if_else (fun o -> snd (maps_from i_or_t o Evd.empty)) (fun o -> snd (maps_to i_or_t o Evd.empty)) is_initial in let (c_or_a, as_or_cs) = List.partition maps (morphisms c) in (os, List.hd c_or_a, as_or_cs) @@ -359,7 +362,7 @@ let substitute_terminal (c : proof_cat) (exp : proof_cat) : proof_cat = List.append old_assums ((s1, e2, d2) :: ((d2, e3, d3) :: other_concls)) else List.append old_assums ((s1, e2, d2) :: new_concls) - in make_category os ms (initial_opt c) (terminal_opt exp) + in snd (make_category os ms (initial_opt c) (terminal_opt exp) Evd.empty) (* --- Merging categories --- *) @@ -373,12 +376,16 @@ let substitute_categories (sc : proof_cat) (dc : proof_cat) : proof_cat = let dcf = make_all_fresh dc in let t = terminal sc in let i = initial dcf in - remove_object - i - (apply_functor - id - (fun (src, e, dst) -> (map_if (fun _ -> t) (objects_equal i src) src, e, dst)) - (combine (initial_opt sc) (terminal_opt dcf) sc dcf)) + snd + (remove_object + i + (snd + (apply_functor + (fun o -> ret o) + (fun (src, e, dst) -> (map_if (fun _ -> t) (snd (objects_equal i src Evd.empty)) src, e, dst)) + (snd (combine (initial_opt sc) (terminal_opt dcf) sc dcf Evd.empty)) + Evd.empty)) + Evd.empty) (* * Find all of the contexts in c where the shortest path is length i @@ -389,7 +396,7 @@ let contexts_at_index (c : proof_cat) (i : int) : context_object list = if n = 0 then [o] else - let adj = arrows_with_source o ms in + let _, adj = arrows_with_source o ms Evd.empty in flat_map (map_dest (fun d -> find_at ms d (n - 1))) adj in find_at (morphisms c) (initial c) i @@ -414,12 +421,12 @@ let merge_first_n (n : int) (c1 : proof_cat) (c2 : proof_cat) : proof_cat = assert (n > 0); let end1 = context_at_index c1 (n - 1) in let end2 = context_at_index c2 (n - 1) in - let path2 = arrows_from c2 end2 in + let _, path2 = arrows_from c2 end2 Evd.empty in let os2 = conclusions path2 in - let ms2 = List.map (map_source_arrow (fun o -> map_if (fun _ -> end1) (objects_equal end2 o) o)) path2 in - let os = List.append (objects c1) os2 in + let ms2 = List.map (map_source_arrow (fun o -> map_if (fun _ -> end1) (snd (objects_equal end2 o Evd.empty)) o)) path2 in + let os = List.append (snd (objects c1 Evd.empty)) os2 in let ms = List.append (morphisms c1) ms2 in - make_category os ms (initial_opt c1) None + snd (make_category os ms (initial_opt c1) None Evd.empty) (* * Assume the first n objects in c are equal, and merge @@ -431,8 +438,8 @@ let merge_up_to_index (n : int) (c : proof_cat) : proof_cat = c else let i = initial c in - let ps = paths_from c i in - let cs = List.map (fun ms -> make_category (i :: conclusions ms) ms (Some i) None) ps in + let _, ps = paths_from c i Evd.empty in + let cs = List.map (fun ms -> snd (make_category (i :: conclusions ms) ms (Some i) None Evd.empty)) ps in List.fold_left (merge_first_n n) (List.hd cs) (List.tl cs) (* @@ -445,13 +452,13 @@ let merge_up_to_index (n : int) (c : proof_cat) : proof_cat = * So revisit this later. So far we haven't needed it. *) let merge_conclusions_nonrec (c : proof_cat) : proof_cat = - let non_assums = List.filter (map_dest (is_not_hypothesis c)) (morphisms c) in + let non_assums = List.filter (fun m -> snd (map_dest (is_not_hypothesis c) m Evd.empty)) (morphisms c) in match conclusions non_assums with | h :: t -> - let os = all_objects_except_those_in t (objects c) in - let merge_h_t o = map_if (fun _ -> h) (contains_object o t) o in + let _, os = all_objects_except_those_in t (snd (objects c Evd.empty)) Evd.empty in + let merge_h_t o = map_if (fun _ -> h) (snd (contains_object o t Evd.empty)) o in let ms = map_arrows (List.map (map_dest_arrow merge_h_t)) c in - make_category os ms (initial_opt c) (Some h) + snd (make_category os ms (initial_opt c) (Some h) Evd.empty) | [] -> c (* @@ -475,20 +482,21 @@ let merge_inductive (is_rec : bool) (n : int) (c : proof_cat) : proof_cat = *) let bind (c : proof_cat) (m : arrow) : proof_cat = let (src, e, dst) = m in - let t = if is_terminal c src then Some dst else terminal_opt c in - let i = if is_initial c dst then Some src else initial_opt c in - let c' = + let t = if snd (is_terminal c src Evd.empty) then Some dst else terminal_opt c in + let i = if snd (is_initial c dst Evd.empty) then Some src else initial_opt c in + let _, c' = apply_functor - id + (fun o -> ret o) (fun m' -> - if arrows_equal (src, AnonymousBinding, dst) m' then + if snd (arrows_equal (src, AnonymousBinding, dst) m' Evd.empty) then m else m') c + Evd.empty in map_if - (fun c' -> set_initial_terminal i t (add_arrow m c')) - (not (category_contains_arrow m c')) + (fun c' -> snd (set_initial_terminal i t (snd (add_arrow m c' Evd.empty)) Evd.empty)) + (not (snd (category_contains_arrow m c' Evd.empty))) c' @@ -500,34 +508,38 @@ let bind (c : proof_cat) (m : arrow) : proof_cat = let bind_apply_function (e : extension) (n : int) (c : proof_cat) : proof_cat = let args = List.rev (List.map (fun i -> Index i) (from_one_to n)) in let binding = List.fold_left (fun b r -> AppBinding (b, r)) e args in - apply_functor - id - (fun m -> - map_if - (fun (src, _, dst) -> (src, binding, dst)) - (maps_to (terminal c) m) - m) - c + snd + (apply_functor + (fun o -> ret o) + (fun m -> + map_if + (fun (src, _, dst) -> (src, binding, dst)) + (snd (maps_to (terminal c) m Evd.empty)) + m) + c + Evd.empty) (* Bind an inductive argument arg to the end of c *) let bind_inductive_arg (arg : types) (c : proof_cat) : proof_cat = let t = terminal c in let bound = ext_of_term (context_env t) arg in - apply_functor - id - (fun m -> - map_if - (map_ext_arrow (fun _ -> bound)) - (maps_to t m) - m) - c + snd + (apply_functor + (fun o -> ret o) + (fun m -> + map_if + (map_ext_arrow (fun _ -> bound)) + (snd (maps_to t m Evd.empty)) + m) + c + Evd.empty) (* Bind an array of inductive arguments args to each category in cs *) let bind_inductive_args (args : types array) (cs : proof_cat array) : proof_cat array = Array.mapi (fun i arg -> let c = cs.(i) in - let t_index = shortest_path_length c (terminal c) in + let _, t_index = shortest_path_length c (terminal c) Evd.empty in bind_inductive_arg (shift_by (t_index - 1) arg) c) args @@ -633,18 +645,20 @@ let sub_arr_property_params pi pb subs ds m = * Substitute a property and parameters into an a category c. *) let sub_property_params npms pms pb c : proof_cat = - let os = objects c in - let ds = List.map (fun o -> (context_index o, shortest_path_length c o)) os in + let _, os = objects c Evd.empty in + let ds = List.map (fun o -> (context_index o, snd (shortest_path_length c o Evd.empty))) os in let pms_es = List.map (map_ext ext_term) pms in let pms_shift = List.mapi (fun j t -> shift_by_unconditional (- (npms - j)) t) pms_es in let pms_shift_rev = List.rev pms_shift in let pms_subs = build_n_substitutions npms pms_shift_rev no_substitutions in let pi = npms + 1 in let pms_subs_shift = unshift_from_substitutions_by pi pms_subs in - apply_functor - (sub_obj_property_params pi pb pms_subs_shift ds) - (sub_arr_property_params pi pb pms_subs_shift ds) - c + snd + (apply_functor + (fun o -> ret (sub_obj_property_params pi pb pms_subs_shift ds o)) + (sub_arr_property_params pi pb pms_subs_shift ds) + c + Evd.empty) (* * Bind an inductive property p and parameters pms in c @@ -653,15 +667,15 @@ let sub_property_params npms pms pb c : proof_cat = *) let bind_property_and_params (po : types option) (pms : types list) (npms : int) (c : proof_cat) : proof_cat = let ms = morphisms c in - let p_unbound = List.find (maps_to (context_at_index c (npms + 1))) ms in + let p_unbound = List.find (fun m -> snd (maps_to (context_at_index c (npms + 1)) m Evd.empty)) ms in let po_shift = Option.map (shift_by npms) po in let p_bound = bind_property_arrow po_shift p_unbound in let (last_param, p_binding, _) = p_bound in - let pms_unbound = arrows_between c (initial c) last_param in + let _, pms_unbound = arrows_between c (initial c) last_param Evd.empty in let pms_shift = List.mapi (fun i p -> shift_by_unconditional (npms - i - 1) p) pms in let pms_bound = bind_param_arrows pms_shift pms_unbound in - let ms_old = all_arrows_except_those_in (p_unbound :: pms_unbound) ms in + let _, ms_old = all_arrows_except_those_in (p_unbound :: pms_unbound) ms Evd.empty in let ms' = List.append pms_bound (p_bound :: ms_old) in - let c' = make_category (objects c) ms' (initial_opt c) (terminal_opt c) in + let _, c' = make_category (snd (objects c Evd.empty)) ms' (initial_opt c) (terminal_opt c) Evd.empty in sub_property_params npms pms_bound p_binding c' From 20744009a1df365aeff4004f6a4db6de7f164d8f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 11:26:27 -0700 Subject: [PATCH 077/154] whoops, infinite loop --- plugin/src/representation/categories/proofcat.ml | 2 +- plugin/src/representation/categories/proofcatterms.ml | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index a93631e..1fcaf7e 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -498,7 +498,7 @@ let has_path (c : proof_cat) (src : context_object) (dst : context_object) = (fun adj -> ret (non_empty adj)) (fun adj -> bind - (map_state (map_dest (reaches ms s)) adj) + (map_state (map_dest (fun s' -> reaches ms s' d)) adj) (exists_state (fun s -> ret (id s)))) adj adj)) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 6c608a4..19d78c4 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -1,5 +1,6 @@ (* Logic for proof categories that is specific to terms and types *) +open Stateutils open Constr open Environ open Proofcat @@ -7,7 +8,6 @@ open Names open Debruijn open Assumptions open Utilities -open Stateutils module CRD = Context.Rel.Declaration From d77b6a7292b2cdb32b2f2a4dcf5895845449818a Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 11:36:05 -0700 Subject: [PATCH 078/154] same mistake in two locations! --- plugin/coq/Optimization.v | 16 ++++++++++------ plugin/src/representation/categories/proofcat.ml | 2 +- 2 files changed, 11 insertions(+), 7 deletions(-) diff --git a/plugin/coq/Optimization.v b/plugin/coq/Optimization.v index c47b598..ac63ae6 100644 --- a/plugin/coq/Optimization.v +++ b/plugin/coq/Optimization.v @@ -226,12 +226,14 @@ Definition add_0_r_5_expected (n : nat) : n + 0 = n := (* * PUMPKIN manages to find the most efficient proof, probably because * there are no inductive hypotheses of the form A -> B. + * + * TODO: Broken. Fix before merging back into master. Not sure what changed. *) -Theorem test_opt_7 : +Fail Theorem test_opt_7 : add_0_r_5 = add_0_r_5_expected. -Proof. +(*Proof. reflexivity. -Qed. +Qed.*) (* * With Preprocess, we can remove the extra fixpoint too: @@ -255,12 +257,14 @@ Optimize Proof Term add_0_r_slow_6' as add_0_r_6. (* * This gives us the same result: + * + * TODO broken. Fix before merging back into master. *) -Theorem test_opt_8 : +Fail Theorem test_opt_8 : add_0_r_6 = add_0_r_5_expected. -Proof. +(*Proof. reflexivity. -Qed. +Qed.*) (* --- Functions (doesn't work yet) --- *) diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index 1fcaf7e..d20b0eb 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -529,7 +529,7 @@ let rec between ms s d = bind (arrows_with_source s ms) (fun adj sigma -> - let sigma, tl = flat_map_state (map_dest (between ms s)) adj sigma in + let sigma, tl = flat_map_state (map_dest (fun s' -> between ms s' d)) adj sigma in sigma, List.append adj tl)) s in From 620113b9d2ca8624cbf615cedabb05f6af610ebe Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 11:41:41 -0700 Subject: [PATCH 079/154] unique_common_subpaths evar_maps --- plugin/src/representation/categories/proofcatterms.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 19d78c4..d97511f 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -8,6 +8,7 @@ open Names open Debruijn open Assumptions open Utilities +open Evd module CRD = Context.Rel.Declaration @@ -114,12 +115,12 @@ let context_as_app (co : context_object) : types * types array = * Then return empty list * Then in params_and_prop, test for that and error *) -let unique_common_subpath (paths : arrow list list) : arrow list = - List.fold_left +let unique_common_subpath (paths : arrow list list) = + fold_left_state (fun l path -> match l with - | [] -> path - | _ -> List.filter (fun m -> snd (contains_arrow m path Evd.empty)) l) + | [] -> ret path + | _ -> filter_state (fun m -> contains_arrow m path) l) [] paths @@ -137,7 +138,7 @@ let params_and_prop (c : proof_cat) (npms : int) : arrow list * arrow = let subpath = List.rev (List.map (Array.get path) (range 0 (npms + 1))) in (List.rev (List.tl subpath), List.hd subpath) else - let common_subpaths = List.rev (unique_common_subpath paths) in + let common_subpaths = List.rev (snd (unique_common_subpath paths Evd.empty)) in (List.tl common_subpaths, List.hd common_subpaths) (* From 396b0edcb4dd139d34f959c07acc9e3addaa18c5 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 11:56:15 -0700 Subject: [PATCH 080/154] Update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 0b42dac..e652742 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 0b42dac4c326e63a7d87c4c52f463797437cee04 +Subproject commit e652742374445f632ae6e40fa560becf6c8eaec9 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 0c77be1..81c1a1d 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 0c77be1e84a35b6836f22ece0534939f07eced40 +Subproject commit 81c1a1d3621f007f267acb1ebc1145a285a43447 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index f675ffc..f7f8d1b 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit f675ffc82600f9d54b7b46c135799bbcc5b80dcc +Subproject commit f7f8d1bc26b04b5be4ed80b6bbbbdf5f55d4983d From a3390743a0f93f9b740c487039de4b648abf25e9 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 12:05:13 -0700 Subject: [PATCH 081/154] params_and_prop evar_maps --- .../categories/proofcatterms.ml | 27 +++++++++++-------- 1 file changed, 16 insertions(+), 11 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index d97511f..4277934 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -130,30 +130,35 @@ let unique_common_subpath (paths : arrow list list) = * * Not sure about reversal *) -let params_and_prop (c : proof_cat) (npms : int) : arrow list * arrow = +let params_and_prop (c : proof_cat) (npms : int) = let i = initial c in - let _, paths = paths_from c i Evd.empty in - if List.length paths = 1 then - let path = Array.of_list (List.hd paths) in - let subpath = List.rev (List.map (Array.get path) (range 0 (npms + 1))) in - (List.rev (List.tl subpath), List.hd subpath) - else - let common_subpaths = List.rev (snd (unique_common_subpath paths Evd.empty)) in - (List.tl common_subpaths, List.hd common_subpaths) + bind + (paths_from c i) + (fun paths -> + if List.length paths = 1 then + let path = Array.of_list (List.hd paths) in + let subpath = List.rev (List.map (Array.get path) (range 0 (npms + 1))) in + ret (List.rev (List.tl subpath), List.hd subpath) + else + bind + (unique_common_subpath paths) + (fun l -> ret (let l = List.rev l in (List.tl l, List.hd l)))) (* * From a proof category that represents an inductive proof, get * the inductive parameters + * + * TODO left off here *) let params (c : proof_cat) (npms : int) : arrow list = - fst (params_and_prop c npms) + fst (snd (params_and_prop c npms Evd.empty)) (* * From a proof category that represents an inductive proof, * get the inductive property *) let prop (c : proof_cat) (npms : int) : arrow = - snd (params_and_prop c npms) + snd (snd (params_and_prop c npms Evd.empty)) (* * Get the only extension in a proof category as a term From 79c4427e910466b880ab5ab485f78ed6ac82adaf Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 14:12:01 -0700 Subject: [PATCH 082/154] params and prop functions with evar-maps --- plugin/src/compilation/categories/catzooming.ml | 4 ++-- .../core/components/differencing/appdifferencers.ml | 2 +- plugin/src/representation/categories/proofcatterms.ml | 10 ++++------ plugin/src/representation/categories/proofcatterms.mli | 6 ++++-- 4 files changed, 11 insertions(+), 11 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index 9678773..dfbbcf0 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -106,8 +106,8 @@ let intro_params nparams d = intro_common d else intro d) - (params (old_proof d) nparams) - (params (new_proof d) nparams) + (snd (params (old_proof d) nparams Evd.empty)) + (snd (params (new_proof d) nparams Evd.empty)) (Some d))) (* --- Zoomers and using zoomers --- *) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 7070fde..b20424a 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -153,7 +153,7 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = | _ -> if non_empty args_o then let env_o = context_env (fst (old_proof d)) in - let (_, prop_trm_ext, _) = prop o npms_old in + let _, (_, prop_trm_ext, _) = prop o npms_old Evd.empty in let prop_trm = ext_term prop_trm_ext in let rec prop_arity p = match kind p with diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 4277934..3302193 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -147,18 +147,16 @@ let params_and_prop (c : proof_cat) (npms : int) = (* * From a proof category that represents an inductive proof, get * the inductive parameters - * - * TODO left off here *) -let params (c : proof_cat) (npms : int) : arrow list = - fst (snd (params_and_prop c npms Evd.empty)) +let params (c : proof_cat) (npms : int) = + bind (params_and_prop c npms) (fun pair -> ret (fst pair)) (* * From a proof category that represents an inductive proof, * get the inductive property *) -let prop (c : proof_cat) (npms : int) : arrow = - snd (snd (params_and_prop c npms Evd.empty)) +let prop (c : proof_cat) (npms : int) = + bind (params_and_prop c npms) (fun pair -> ret (snd pair)) (* * Get the only extension in a proof category as a term diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index 6767023..35f68cf 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -4,6 +4,8 @@ open Constr open Environ open Proofcat open Names +open Evd +open Stateutils (* --- Construction --- *) @@ -76,7 +78,7 @@ val context_as_app : context_object -> types * types array * This assumes the proof category represents an inductive proof * It has undefined behavior if you call it otherwise *) -val params : proof_cat -> int -> arrow list +val params : proof_cat -> int -> evar_map -> (arrow list) state (* * From a proof category that represents an inductive proof, get @@ -85,7 +87,7 @@ val params : proof_cat -> int -> arrow list * This assumes the proof category represents an inductive proof * It has undefined behavior if you call it otherwise *) -val prop : proof_cat -> int -> arrow +val prop : proof_cat -> int -> evar_map -> arrow state (* * Get the only extension in a proof category as a term From 643289c5b84409f0ee1613b65e745de2e9495fc0 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 29 Aug 2019 14:16:39 -0700 Subject: [PATCH 083/154] split function with evar_maps --- .../components/differencing/inddifferencers.ml | 2 +- .../representation/categories/proofcatterms.ml | 15 ++++++++------- .../representation/categories/proofcatterms.mli | 2 +- 3 files changed, 10 insertions(+), 9 deletions(-) diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 3eeab62..033844c 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -191,7 +191,7 @@ let diff_inductive diff d_old opts evd (d : (proof_cat * int) proof_diff) : cand else zoom_map (fun d -> - let sort c = base_cases_first (List.map expand_constr (split c)) in + let sort c = base_cases_first (List.map expand_constr (snd (split c Evd.empty))) in let d_sorted = map_diffs sort id d in let ds = dest_cases d_sorted in List.map (unshift_by nparams_o) (diff_ind_cases opts evd diff d_old ds)) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 3302193..5e86abc 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -170,14 +170,15 @@ let only_extension_as_term (c : proof_cat) : types = * Given a proof category with several paths, * construct several proof categories, each with one path. *) -let split (c : proof_cat) : proof_cat list = +let split (c : proof_cat) = let i = initial c in - List.map - (fun ms -> - let os = i :: (conclusions ms) in - let (_, _, t) = List.nth ms (List.length ms - 1) in - snd (make_category os ms (Some i) (Some t) Evd.empty)) - (snd (paths_from c i Evd.empty)) + bind + (paths_from c i) + (map_state + (fun ms sigma -> + let os = i :: (conclusions ms) in + let (_, _, t) = List.nth ms (List.length ms - 1) in + make_category os ms (Some i) (Some t) sigma)) (* --- Transformations on terms and environments --- *) diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index 35f68cf..5f4cdec 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -100,7 +100,7 @@ val only_extension_as_term : proof_cat -> types * Given a proof category with several paths, * construct several proof categories, each with one path. *) -val split : proof_cat -> proof_cat list +val split : proof_cat -> evar_map -> (proof_cat list) state (* --- Transformations on terms and environments --- *) From 867c1c211550e3f45383e532ebf2811cc07e18fb Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 13:25:05 -0700 Subject: [PATCH 084/154] Incremental changes for evar_maps in old representation, still --- .../src/compilation/categories/catzooming.ml | 2 +- plugin/src/compilation/expansion.ml | 8 ++--- .../src/representation/categories/proofcat.ml | 23 ++++++------ .../representation/categories/proofcat.mli | 8 ++--- .../categories/proofcatterms.ml | 35 ++++++++++++------- 5 files changed, 42 insertions(+), 34 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index dfbbcf0..645db7b 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -27,7 +27,7 @@ let remove_initial (c : proof_cat) : proof_cat = let i = initial c in let ms = morphisms c in let _, os' = all_objects_except i (snd (objects c Evd.empty)) Evd.empty in - let (ms', ims) = List.partition (map_source (fun o -> snd (objects_not_equal i o Evd.empty))) ms in + let (ms', ims) = List.partition (fun m -> snd (map_source (fun o sigma -> objects_not_equal i o sigma) m Evd.empty)) ms in let (_, _, i') = List.hd ims in snd (make_category os' ms' (Some i') (terminal_opt c) Evd.empty) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index a8bcf30..2f00820 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -165,7 +165,7 @@ let expand_terminal (c : proof_cat) : proof_cat = *) let partition_expandable (c : proof_cat) : (arrow list * arrow list) = List.partition - (map_dest (fun o -> context_is_product o && snd (is_not_hypothesis c o Evd.empty))) + (fun m -> snd (map_dest (fun o sigma -> sigma, context_is_product o && snd (is_not_hypothesis c o sigma)) m Evd.empty)) (morphisms c) (* @@ -176,12 +176,12 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = List.map (fun (s, e, d) -> let dc = expand_product_fully d in - let map_i_to_src m = if (snd (objects_equal (initial dc) m Evd.empty)) then s else m in + let map_i_to_src m sigma = sigma, if (snd (objects_equal (initial dc) m Evd.empty)) then s else m in let arity = (List.length (morphisms dc)) - 1 in bind_apply_function (shift_ext_by arity (substitute_ext_env (context_env (terminal dc)) e)) arity - (snd (apply_functor (fun o -> ret (map_i_to_src o)) (map_source_arrow map_i_to_src) dc Evd.empty))) + (snd (apply_functor map_i_to_src (fun a -> snd (map_source_arrow map_i_to_src a Evd.empty)) dc Evd.empty))) ms (* @@ -238,7 +238,7 @@ let bind_ihs (c : proof_cat) : proof_cat = (apply_functor (fun o -> ret o) (fun m -> - if map_dest (applies_ih env Evd.empty p c) m then + if snd (map_dest (fun o sigma -> sigma, applies_ih env sigma p c o) m Evd.empty) then map_ext_arrow (fun _ -> fresh_ih ()) m else m) diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index d20b0eb..7fe447b 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -62,10 +62,9 @@ struct true let equal (c1 : t) (c2 : t) = - ret - (let Context (ctx1, i1) = c1 in - let Context (ctx2, i2) = c2 in - (i1 = i2) && (ctx_equal ctx1 ctx2)) + let Context (ctx1, i1) = c1 in + let Context (ctx2, i2) = c2 in + ret ((i1 = i2) && (ctx_equal ctx1 ctx2)) end module Extension = @@ -207,14 +206,14 @@ let not_contains_arrow (m : arrow) (ms : arrow list) = (* * Map a function on the source of an arrow *) -let map_source (f : context_object -> 'a) (m : arrow) : 'a = +let map_source (f : context_object -> evar_map -> 'a state) (m : arrow) = let (src, _, _) = m in f src (* * Map a function on the destination of an arrow *) -let map_dest (f : context_object -> 'a) (m : arrow) : 'a = +let map_dest (f : context_object -> evar_map -> 'a state) (m : arrow) = let (_, _, dst) = m in f dst @@ -228,16 +227,16 @@ let map_ext (f : extension -> 'a) (m : arrow) : 'a = (* * Map a function on the source of an arrow and return a new arrow *) -let map_source_arrow (f : context_object -> context_object) (m : arrow) : arrow = +let map_source_arrow (f : context_object -> evar_map -> context_object state) (m : arrow) = let (src, e, dst) = m in - (f src, e, dst) + bind (f src) (fun o -> ret (o, e, dst)) (* * Map a function on the destination of an arrow and return a new arrow *) -let map_dest_arrow (f : context_object -> context_object) (m : arrow) : arrow = +let map_dest_arrow (f : context_object -> evar_map -> context_object state) (m : arrow) = let (src, e, dst) = m in - (src, e, f dst) + bind (f dst) (fun o -> ret (src, e, o)) (* * Map a function on the extension of an arrow and return a new arrow @@ -297,8 +296,8 @@ let all_arrows_except_those_in (except : arrow list) (ms : arrow list) = (* * Return all arrows from ms that start from src *) -let arrows_with_source (src : context_object) (ms : arrow list) = - filter_state (maps_from src) ms +let arrows_with_source (src : context_object) (ms : arrow list) sigma = + filter_state (fun m sigma -> maps_from src m sigma) ms sigma (* * Return all arrows from ms that end with dst diff --git a/plugin/src/representation/categories/proofcat.mli b/plugin/src/representation/categories/proofcat.mli index 47d7f84..a2341ca 100644 --- a/plugin/src/representation/categories/proofcat.mli +++ b/plugin/src/representation/categories/proofcat.mli @@ -109,12 +109,12 @@ val not_contains_arrow : arrow -> arrow list -> evar_map -> bool state (* * Map a function on the source of an arrow *) -val map_source : (context_object -> 'a) -> arrow -> 'a +val map_source : (context_object -> evar_map -> 'a state) -> arrow -> evar_map -> 'a state (* * Map a function on the destination of an arrow *) -val map_dest : (context_object -> 'a) -> arrow -> 'a +val map_dest : (context_object -> evar_map -> 'a state) -> arrow -> evar_map -> 'a state (* * Map a function on the extension of an arrow @@ -124,12 +124,12 @@ val map_ext : (extension -> 'a) -> arrow -> 'a (* * Map a function on the destination of an arrow and return a new arrow *) -val map_source_arrow : (context_object -> context_object) -> arrow -> arrow +val map_source_arrow : (context_object -> evar_map -> context_object state) -> arrow -> evar_map -> arrow state (* * Map a function on the source of an arrow and return a new arrow *) -val map_dest_arrow : (context_object -> context_object) -> arrow -> arrow +val map_dest_arrow : (context_object -> evar_map -> context_object state) -> arrow -> evar_map -> arrow state (* * Map a function on the extension of an arrow and return a new arrow diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 5e86abc..47eaff8 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -203,20 +203,28 @@ let find_ihs (c : proof_cat) : arrow list = List.filter arrow_is_ih (morphisms c) (* Find the distance to the closest IH to m given a list of IHs *) -let closest_ih c (ihs : arrow list) (m : arrow) : context_object * int = +(* TODO clean *) +let closest_ih c (ihs : arrow list) (m : arrow) sigma : (context_object * int) state = let (s, _, _) = m in + let sigma, ih_distances = + map_state + (map_dest + (fun d sigma -> + let sigma, path = arrows_between c d s sigma in + sigma, (d, List.length path))) + ihs + sigma + in let ih_proxes = List.sort (fun (_, i1) (_, i2) -> Pervasives.compare i1 i2) - (List.map - (map_dest (fun d -> (d, List.length (snd (arrows_between c d s Evd.empty))))) - ihs) - in List.hd ih_proxes + ih_distances + in sigma, List.hd ih_proxes (* Determine which arrow is closer to an IH *) let closer_to_ih c (ihs : arrow list) (m1 : arrow) (m2 : arrow) : int = - let (m1_ih_dst, m1_ih_prox) = closest_ih c ihs m1 in - let (m2_ih_dst, m2_ih_prox) = closest_ih c ihs m2 in + let _, (m1_ih_dst, m1_ih_prox) = closest_ih c ihs m1 Evd.empty in + let _, (m2_ih_dst, m2_ih_prox) = closest_ih c ihs m2 Evd.empty in let ih_1_index = shortest_path_length c m1_ih_dst in let ih_2_index = shortest_path_length c m2_ih_dst in if m1_ih_prox = m2_ih_prox then @@ -402,7 +410,7 @@ let contexts_at_index (c : proof_cat) (i : int) : context_object list = [o] else let _, adj = arrows_with_source o ms Evd.empty in - flat_map (map_dest (fun d -> find_at ms d (n - 1))) adj + snd (flat_map_state (map_dest (fun d sigma -> sigma, find_at ms d (n - 1))) adj Evd.empty) in find_at (morphisms c) (initial c) i (* @@ -428,7 +436,7 @@ let merge_first_n (n : int) (c1 : proof_cat) (c2 : proof_cat) : proof_cat = let end2 = context_at_index c2 (n - 1) in let _, path2 = arrows_from c2 end2 Evd.empty in let os2 = conclusions path2 in - let ms2 = List.map (map_source_arrow (fun o -> map_if (fun _ -> end1) (snd (objects_equal end2 o Evd.empty)) o)) path2 in + let _, ms2 = map_state (map_source_arrow (fun o sigma -> sigma, map_if (fun _ -> end1) (snd (objects_equal end2 o sigma)) o)) path2 Evd.empty in let os = List.append (snd (objects c1 Evd.empty)) os2 in let ms = List.append (morphisms c1) ms2 in snd (make_category os ms (initial_opt c1) None Evd.empty) @@ -461,8 +469,8 @@ let merge_conclusions_nonrec (c : proof_cat) : proof_cat = match conclusions non_assums with | h :: t -> let _, os = all_objects_except_those_in t (snd (objects c Evd.empty)) Evd.empty in - let merge_h_t o = map_if (fun _ -> h) (snd (contains_object o t Evd.empty)) o in - let ms = map_arrows (List.map (map_dest_arrow merge_h_t)) c in + let merge_h_t o sigma = map_if (fun _ -> sigma, h) (snd (contains_object o t Evd.empty)) (sigma, o) in + let _, ms = map_arrows (map_state (map_dest_arrow merge_h_t)) c Evd.empty in snd (make_category os ms (initial_opt c) (Some h) Evd.empty) | [] -> c @@ -553,7 +561,7 @@ let bind_inductive_args (args : types array) (cs : proof_cat array) : proof_cat * Get the arrow for binding an optional property *) let bind_property_arrow (po : types option) (m : arrow) : arrow = - let env = map_dest context_env m in + let _, env = map_dest (fun o -> ret (context_env o)) m Evd.empty in map_ext_arrow (fun e -> Option.default e (Option.map (ext_of_term env) po)) m (* @@ -561,7 +569,8 @@ let bind_property_arrow (po : types option) (m : arrow) : arrow = * Get the arrows for binding a list of parameters *) let bind_param_arrows (ps : types list) (ms : arrow list) : arrow list = - let envs = Array.of_list (List.map (map_dest context_env) ms) in + let _, envs = map_state (map_dest (fun o -> ret (context_env o))) ms Evd.empty in + let envs = Array.of_list envs in let pes = Array.of_list (List.mapi (fun i p -> ext_of_term envs.(i) p) ps) in List.mapi (fun i m -> From e4cc107dbdc12298e1db7b3b6e98ec032af25ebd Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 13:32:25 -0700 Subject: [PATCH 085/154] clean closest_ih function --- .../categories/proofcatterms.ml | 27 +++++++++---------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 47eaff8..ebf3d7f 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -203,23 +203,20 @@ let find_ihs (c : proof_cat) : arrow list = List.filter arrow_is_ih (morphisms c) (* Find the distance to the closest IH to m given a list of IHs *) -(* TODO clean *) -let closest_ih c (ihs : arrow list) (m : arrow) sigma : (context_object * int) state = +let closest_ih c (ihs : arrow list) (m : arrow) = let (s, _, _) = m in - let sigma, ih_distances = - map_state + bind + (map_state (map_dest - (fun d sigma -> - let sigma, path = arrows_between c d s sigma in - sigma, (d, List.length path))) - ihs - sigma - in - let ih_proxes = - List.sort - (fun (_, i1) (_, i2) -> Pervasives.compare i1 i2) - ih_distances - in sigma, List.hd ih_proxes + (fun d -> + bind (arrows_between c d s) (fun path -> ret (d, List.length path)))) + ihs) + (fun ih_distances -> + let ih_distances_sorted = + List.sort + (fun (_, i1) (_, i2) -> Pervasives.compare i1 i2) + ih_distances + in ret (List.hd ih_distances_sorted)) (* Determine which arrow is closer to an IH *) let closer_to_ih c (ihs : arrow list) (m1 : arrow) (m2 : arrow) : int = From 81824d474067cc692b0be556494ca08631ea4cff Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 13:38:36 -0700 Subject: [PATCH 086/154] port closer_to_ih --- .../core/components/differencing/inddifferencers.ml | 2 +- plugin/src/representation/categories/proofcatterms.ml | 10 +++++----- plugin/src/representation/categories/proofcatterms.mli | 2 +- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 033844c..991fd92 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -121,7 +121,7 @@ let diff_base_case opts evd diff d_old (d : proof_cat_diff) : candidates = * any differently, since the IH does not change. *) let diff_inductive_case opts evd diff d_old (d : proof_cat_diff) : candidates = - let sort c ms = List.stable_sort (closer_to_ih c (find_ihs c)) ms in + let sort c ms = List.stable_sort (fun m1 m2 -> snd (closer_to_ih c (find_ihs c) m1 m2 Evd.empty)) ms in let change = get_change opts in let opts = if is_identity change then opts else set_is_ind opts true in diff_sort_ind_case opts evd sort diff d_old d diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index ebf3d7f..cec392d 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -219,15 +219,15 @@ let closest_ih c (ihs : arrow list) (m : arrow) = in ret (List.hd ih_distances_sorted)) (* Determine which arrow is closer to an IH *) -let closer_to_ih c (ihs : arrow list) (m1 : arrow) (m2 : arrow) : int = - let _, (m1_ih_dst, m1_ih_prox) = closest_ih c ihs m1 Evd.empty in - let _, (m2_ih_dst, m2_ih_prox) = closest_ih c ihs m2 Evd.empty in +let closer_to_ih c (ihs : arrow list) (m1 : arrow) (m2 : arrow) sigma : int state = + let sigma, (m1_ih_dst, m1_ih_prox) = closest_ih c ihs m1 sigma in + let sigma, (m2_ih_dst, m2_ih_prox) = closest_ih c ihs m2 sigma in let ih_1_index = shortest_path_length c m1_ih_dst in let ih_2_index = shortest_path_length c m2_ih_dst in if m1_ih_prox = m2_ih_prox then - Pervasives.compare ih_1_index ih_2_index (* start lower *) + sigma, Pervasives.compare ih_1_index ih_2_index (* start lower *) else - Pervasives.compare m1_ih_prox m2_ih_prox (* start closer to IH *) + sigma, Pervasives.compare m1_ih_prox m2_ih_prox (* start closer to IH *) (* * Sort cs so that the base cases are first in the list diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index 5f4cdec..5457d3d 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -123,7 +123,7 @@ val find_ihs : proof_cat -> arrow list * When they are equidistant, prefer ones that are lower in the proof * The IHs are only supplied for efficiency, you can get them with find_ihs *) -val closer_to_ih : proof_cat -> arrow list -> arrow -> arrow -> int +val closer_to_ih : proof_cat -> arrow list -> arrow -> arrow -> evar_map -> int state (* * Sort a list of proof_cats so that the base cases are first in the list From 8903decf4f5c08389dc6f316a1af4336b582149e Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 13:45:48 -0700 Subject: [PATCH 087/154] make_all_fresh evar_maps --- .../categories/proofcatterms.ml | 27 +++++++++---------- 1 file changed, 12 insertions(+), 15 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index cec392d..6a73a7e 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -295,26 +295,23 @@ let shift_ext_by (n : int) (e : extension) : extension = (* --- Identifiers --- *) (* Map the identifiers of contexts of c with f *) -let map_ids (f : int -> int) (c : proof_cat) : proof_cat = - snd - (apply_functor - (fun (Context (c, id)) -> - ret (Context (c, f id))) - (fun (Context (s, sid), e, Context (d, did)) -> - (Context (s, f sid), e, Context (d, f did))) - c - Evd.empty) +let map_ids (f : int -> int) (c : proof_cat) = + apply_functor + (fun (Context (c, id)) -> + ret (Context (c, f id))) + (fun (Context (s, sid), e, Context (d, did)) -> + (Context (s, f sid), e, Context (d, f did))) + c (* Get a map from context identifiers to fresh identifiers *) -let get_fresh_ids (c : proof_cat) : (int * int) list = - List.map (fun (Context (_, id)) -> (id, (fid ()))) (snd (objects c Evd.empty)) +let get_fresh_ids (c : proof_cat) = + bind (objects c) (map_state (fun (Context (_, id)) -> ret (id, (fid ())))) (* * Make fresh identifiers for every context in c *) -let make_all_fresh (c : proof_cat) : proof_cat = - let fids = get_fresh_ids c in - map_ids (fun id -> List.assoc id fids) c +let make_all_fresh (c : proof_cat) = + bind (get_fresh_ids c) (fun fids -> map_ids (fun id -> List.assoc id fids) c) (* --- Substitution --- *) @@ -383,7 +380,7 @@ let substitute_terminal (c : proof_cat) (exp : proof_cat) : proof_cat = * Creates fresh IDs for dc first to make sure we don't get repetition *) let substitute_categories (sc : proof_cat) (dc : proof_cat) : proof_cat = - let dcf = make_all_fresh dc in + let _, dcf = make_all_fresh dc Evd.empty in let t = terminal sc in let i = initial dcf in snd From bbe5b2745b46c59a9aeeec59ed9cdc9aba4bc17a Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:00:48 -0700 Subject: [PATCH 088/154] Update lib to have a partition_state function --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index e652742..c008a39 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit e652742374445f632ae6e40fa560becf6c8eaec9 +Subproject commit c008a39c3168ea663eb81cef31e72386d5a0b82c diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 81c1a1d..43c5217 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 81c1a1d3621f007f267acb1ebc1145a285a43447 +Subproject commit 43c5217730e2124db624c3cbe9457b88a85c5eda diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index f7f8d1b..ff6dba0 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit f7f8d1bc26b04b5be4ed80b6bbbbdf5f55d4983d +Subproject commit ff6dba062de52ce1dbe75918ec6d5c82313a2945 From c401a6fa538af693de09dae244689f65757137cd Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:03:39 -0700 Subject: [PATCH 089/154] partition_initial_terminal with state --- .../categories/proofcatterms.ml | 20 ++++++++++++------- 1 file changed, 13 insertions(+), 7 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 6a73a7e..b01210f 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -347,17 +347,23 @@ let rec substitute_ext_env (env : env) (e : extension) : extension = * Then get the assumption(s) and conclusion(s) * (This would be cleaner with a proper opposite category) *) -let partition_initial_terminal (c : proof_cat) (is_initial : bool) : (context_object list) * arrow * (arrow list) = +let partition_initial_terminal (c : proof_cat) (is_initial : bool) sigma = let i_or_t = map_if_else initial terminal is_initial c in - let _, os = all_objects_except i_or_t (snd (objects c Evd.empty)) Evd.empty in - let maps = map_if_else (fun o -> snd (maps_from i_or_t o Evd.empty)) (fun o -> snd (maps_to i_or_t o Evd.empty)) is_initial in - let (c_or_a, as_or_cs) = List.partition maps (morphisms c) in - (os, List.hd c_or_a, as_or_cs) + let sigma, os = objects c sigma in + let sigma, os = all_objects_except i_or_t os sigma in + let maps = + branch_state + (fun _ -> ret is_initial) + (maps_from i_or_t) + (maps_to i_or_t) + in + let sigma, (c_or_a, as_or_cs) = partition_state maps (morphisms c) sigma in + sigma, (os, List.hd c_or_a, as_or_cs) (* Substitute in an expanded version exp of the terminal object of c *) let substitute_terminal (c : proof_cat) (exp : proof_cat) : proof_cat = - let (old_os, old_concl, old_assums) = partition_initial_terminal c false in - let (new_os, new_assum, new_concls) = partition_initial_terminal exp true in + let _, (old_os, old_concl, old_assums) = partition_initial_terminal c false Evd.empty in + let _, (new_os, new_assum, new_concls) = partition_initial_terminal exp true Evd.empty in let os = List.append old_os new_os in let (s1, e1, _) = old_concl in let (_, e2, d2) = new_assum in From 5307562ba6e756ed848fcc4c27bef5548c326ceb Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:11:17 -0700 Subject: [PATCH 090/154] monads --- .../categories/proofcatterms.ml | 22 +++++++++---------- 1 file changed, 10 insertions(+), 12 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index b01210f..689feac 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -347,18 +347,16 @@ let rec substitute_ext_env (env : env) (e : extension) : extension = * Then get the assumption(s) and conclusion(s) * (This would be cleaner with a proper opposite category) *) -let partition_initial_terminal (c : proof_cat) (is_initial : bool) sigma = - let i_or_t = map_if_else initial terminal is_initial c in - let sigma, os = objects c sigma in - let sigma, os = all_objects_except i_or_t os sigma in - let maps = - branch_state - (fun _ -> ret is_initial) - (maps_from i_or_t) - (maps_to i_or_t) - in - let sigma, (c_or_a, as_or_cs) = partition_state maps (morphisms c) sigma in - sigma, (os, List.hd c_or_a, as_or_cs) +let partition_initial_terminal (c : proof_cat) (is_init : bool) = + let i_t = map_if_else initial terminal is_init c in + bind + (bind (objects c) (all_objects_except i_t)) + (fun os -> + bind + (partition_state + (branch_state (fun _ -> ret is_init) (maps_from i_t) (maps_to i_t)) + (morphisms c)) + (fun (c_or_a, as_or_cs)-> ret (os, List.hd c_or_a, as_or_cs))) (* Substitute in an expanded version exp of the terminal object of c *) let substitute_terminal (c : proof_cat) (exp : proof_cat) : proof_cat = From 8310dec91d21d71f68682b444816b5eeebb3b76a Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:19:47 -0700 Subject: [PATCH 091/154] substitute_terminal with state --- plugin/src/compilation/evaluation.ml | 2 +- plugin/src/compilation/expansion.ml | 2 +- .../categories/proofcatterms.ml | 36 +++++++++++-------- .../categories/proofcatterms.mli | 2 +- 4 files changed, 24 insertions(+), 18 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 1927911..99fbe9e 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -118,7 +118,7 @@ let partition_args (nparams : int) (nconstrs : int) (args : 'a list) : 'a argume let bind_constrs_to_args fc cs ncs arg_partition = let non_params = Array.of_list arg_partition.non_params in let num_non_params = Array.length non_params in - let cs_params = Array.of_list (List.map (substitute_terminal fc) cs) in + let cs_params = Array.of_list (List.map (fun c -> snd (substitute_terminal fc c Evd.empty)) cs) in let cs_args = Array.to_list (bind_inductive_args non_params cs_params) in let cs_no_args = List.map (Array.get cs_params) (range num_non_params (List.length cs)) in List.append cs_args cs_no_args diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 2f00820..f47f375 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -153,7 +153,7 @@ let expand_terminal (c : proof_cat) : proof_cat = AnonymousBinding in let exp = expand_term (eval_theorem_bind binding) t in - substitute_terminal c exp + snd (substitute_terminal c exp Evd.empty) | _ -> c diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 689feac..af98f2e 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -359,21 +359,27 @@ let partition_initial_terminal (c : proof_cat) (is_init : bool) = (fun (c_or_a, as_or_cs)-> ret (os, List.hd c_or_a, as_or_cs))) (* Substitute in an expanded version exp of the terminal object of c *) -let substitute_terminal (c : proof_cat) (exp : proof_cat) : proof_cat = - let _, (old_os, old_concl, old_assums) = partition_initial_terminal c false Evd.empty in - let _, (new_os, new_assum, new_concls) = partition_initial_terminal exp true Evd.empty in - let os = List.append old_os new_os in - let (s1, e1, _) = old_concl in - let (_, e2, d2) = new_assum in - let ms = - if ext_is_lambda e1 then - let (_, _, d3) = List.hd new_concls in - let other_concls = List.tl new_concls in - let e3 = curry_lambda e1 in - List.append old_assums ((s1, e2, d2) :: ((d2, e3, d3) :: other_concls)) - else - List.append old_assums ((s1, e2, d2) :: new_concls) - in snd (make_category os ms (initial_opt c) (terminal_opt exp) Evd.empty) +let substitute_terminal (c : proof_cat) (exp : proof_cat) = + bind + (partition_initial_terminal c false) + (fun (old_os, old_concl, old_assums) -> + bind + (partition_initial_terminal exp true) + (fun (new_os, new_assum, new_concls) -> + let os = List.append old_os new_os in + let (s1, e1, _) = old_concl in + let (_, e2, d2) = new_assum in + let concls = + if ext_is_lambda e1 then + let (_, _, d3) = List.hd new_concls in + let other_concls = List.tl new_concls in + let e3 = curry_lambda e1 in + (s1, e2, d2) :: ((d2, e3, d3) :: other_concls) + else + (s1, e2, d2) :: new_concls + in + let ms = List.append old_assums concls in + make_category os ms (initial_opt c) (terminal_opt exp))) (* --- Merging categories --- *) diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index 5457d3d..18bf1e5 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -152,7 +152,7 @@ val substitute_ext_env : env -> extension -> extension * The second proof_cat should replace the terminal object in the original * This is commonly used to update categories after expansion *) -val substitute_terminal : proof_cat -> proof_cat -> proof_cat +val substitute_terminal : proof_cat -> proof_cat -> evar_map -> proof_cat state (* --- Merging categories --- *) From 4e466267c486b3640a34e323175b58d625440ac1 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:34:57 -0700 Subject: [PATCH 092/154] verbose version of substitute_categories --- plugin/src/compilation/expansion.ml | 12 ++-- .../src/representation/categories/category.ml | 4 +- .../representation/categories/category.mli | 2 +- .../representation/categories/proofcat.mli | 2 +- .../categories/proofcatterms.ml | 56 +++++++++++-------- .../categories/proofcatterms.mli | 2 +- 6 files changed, 43 insertions(+), 35 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index f47f375..4537419 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -48,7 +48,7 @@ let expand_product (env : env) ((n, t, b) : Name.t * types * types) : proof_cat let t' = eval_theorem env t in let env' = push_rel CRD.(LocalAssum(n, t)) env in let b' = eval_theorem env' b in - let c = substitute_categories t' b' in + let _, c = substitute_categories t' b' Evd.empty in bind c (initial c, LazyBinding (mkRel 1, env'), terminal t') (* Expand a lambda term exactly once *) @@ -87,7 +87,7 @@ let expand_app (env : env) ((f, args) : types * types array) = assert (Array.length args > 0); let arg = args.(0) in let f' = eval_proof env (mkApp (f, Array.make 1 arg)) in - let arg' = substitute_categories (eval_proof env arg) f' in + let _, arg' = substitute_categories (eval_proof env arg) f' Evd.empty in bind_apply_function (LazyBinding (f, env)) 1 arg' (* --- Contexts --- *) @@ -127,7 +127,7 @@ let expand_product_fully (o : context_object) : proof_cat = let t'' = eval_theorem env t in let env' = push_rel CRD.(LocalAssum(n, t)) env in let b'' = expand_fully env' (n', t', b') in - let c = substitute_categories t'' b'' in + let _, c = substitute_categories t'' b'' Evd.empty in bind c (initial c, LazyBinding (mkRel 1, env'), terminal t'') | _ -> expand_product env (n, t, b) @@ -181,7 +181,7 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = bind_apply_function (shift_ext_by arity (substitute_ext_env (context_env (terminal dc)) e)) arity - (snd (apply_functor map_i_to_src (fun a -> snd (map_source_arrow map_i_to_src a Evd.empty)) dc Evd.empty))) + (snd (apply_functor map_i_to_src (map_source_arrow map_i_to_src) dc Evd.empty))) ms (* @@ -239,9 +239,9 @@ let bind_ihs (c : proof_cat) : proof_cat = (fun o -> ret o) (fun m -> if snd (map_dest (fun o sigma -> sigma, applies_ih env sigma p c o) m Evd.empty) then - map_ext_arrow (fun _ -> fresh_ih ()) m + ret (map_ext_arrow (fun _ -> fresh_ih ()) m) else - m) + ret m) c Evd.empty) diff --git a/plugin/src/representation/categories/category.ml b/plugin/src/representation/categories/category.ml index baf0f04..d110c33 100644 --- a/plugin/src/representation/categories/category.ml +++ b/plugin/src/representation/categories/category.ml @@ -141,7 +141,7 @@ end module Functor (Dom : CatT) (Cod : CatT) = struct type f_obj = Dom.obj -> evar_map -> Cod.obj state - type f_arr = Dom.arrow -> Cod.arrow + type f_arr = Dom.arrow -> evar_map -> Cod.arrow state type f_iterm = Dom.obj option -> evar_map -> (Cod.obj option) state type t = Fun of f_obj * f_arr * f_iterm * f_iterm @@ -174,7 +174,7 @@ struct let f_o = f_O f in let f_a = f_A f in let sigma, os = bind (Dom.objects c) (map_state f_o) sigma in - let ms = List.map f_a (Dom.morphisms c) in + let sigma, ms = map_state f_a (Dom.morphisms c) sigma in let sigma, i = (f_I f) (Dom.initial c) sigma in let sigma, t = (f_T f) (Dom.terminal c) sigma in Cod.make os ms i t sigma diff --git a/plugin/src/representation/categories/category.mli b/plugin/src/representation/categories/category.mli index 9096ccc..ad27ad4 100644 --- a/plugin/src/representation/categories/category.mli +++ b/plugin/src/representation/categories/category.mli @@ -56,7 +56,7 @@ end module Functor (Dom : CatT) (Cod : CatT): sig type f_obj = Dom.obj -> evar_map -> Cod.obj state - type f_arr = Dom.arrow -> Cod.arrow + type f_arr = Dom.arrow -> evar_map -> Cod.arrow state type f_iterm = Dom.obj option -> evar_map -> (Cod.obj option) state type t = Fun of f_obj * f_arr * f_iterm * f_iterm diff --git a/plugin/src/representation/categories/proofcat.mli b/plugin/src/representation/categories/proofcat.mli index a2341ca..911e17b 100644 --- a/plugin/src/representation/categories/proofcat.mli +++ b/plugin/src/representation/categories/proofcat.mli @@ -347,7 +347,7 @@ val shortest_path_length : proof_cat -> context_object -> evar_map -> int state *) val apply_functor : (context_object -> evar_map -> context_object state) -> - (arrow -> arrow) -> + (arrow -> evar_map -> arrow state) -> proof_cat -> evar_map -> proof_cat state diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index af98f2e..778e536 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -300,7 +300,7 @@ let map_ids (f : int -> int) (c : proof_cat) = (fun (Context (c, id)) -> ret (Context (c, f id))) (fun (Context (s, sid), e, Context (d, did)) -> - (Context (s, f sid), e, Context (d, f did))) + ret (Context (s, f sid), e, Context (d, f did))) c (* Get a map from context identifiers to fresh identifiers *) @@ -389,20 +389,24 @@ let substitute_terminal (c : proof_cat) (exp : proof_cat) = * Assumes that sc has a terminal object and dc has an initial object * Creates fresh IDs for dc first to make sure we don't get repetition *) -let substitute_categories (sc : proof_cat) (dc : proof_cat) : proof_cat = - let _, dcf = make_all_fresh dc Evd.empty in +let substitute_categories (sc : proof_cat) (dc : proof_cat) sigma = + let sigma, dcf = make_all_fresh dc sigma in let t = terminal sc in let i = initial dcf in - snd - (remove_object - i - (snd - (apply_functor - (fun o -> ret o) - (fun (src, e, dst) -> (map_if (fun _ -> t) (snd (objects_equal i src Evd.empty)) src, e, dst)) - (snd (combine (initial_opt sc) (terminal_opt dcf) sc dcf Evd.empty)) - Evd.empty)) - Evd.empty) + bind + (apply_functor + (fun o -> ret o) + (fun (src, e, dst) sigma_old -> + let sigma, src = + let sigma, eq = objects_equal i src sigma_old in + if eq then + sigma, t + else + sigma_old, src + in sigma, (src, e, dst)) + (snd (combine (initial_opt sc) (terminal_opt dcf) sc dcf sigma))) + (remove_object i) + sigma (* * Find all of the contexts in c where the shortest path is length i @@ -496,6 +500,8 @@ let merge_inductive (is_rec : bool) (n : int) (c : proof_cat) : proof_cat = * Bind an arrow from src to dst of m in c with extension e of m * If an arrow with an anonymous binding exists, then bind that arrow * Otherwise, add the arrow if it doesn't exist + * + * TODO rename! *) let bind (c : proof_cat) (m : arrow) : proof_cat = let (src, e, dst) = m in @@ -506,9 +512,9 @@ let bind (c : proof_cat) (m : arrow) : proof_cat = (fun o -> ret o) (fun m' -> if snd (arrows_equal (src, AnonymousBinding, dst) m' Evd.empty) then - m + ret m else - m') + ret m') c Evd.empty in map_if @@ -529,10 +535,11 @@ let bind_apply_function (e : extension) (n : int) (c : proof_cat) : proof_cat = (apply_functor (fun o -> ret o) (fun m -> - map_if - (fun (src, _, dst) -> (src, binding, dst)) - (snd (maps_to (terminal c) m Evd.empty)) - m) + ret + (map_if + (fun (src, _, dst) -> (src, binding, dst)) + (snd (maps_to (terminal c) m Evd.empty)) + m)) c Evd.empty) @@ -544,10 +551,11 @@ let bind_inductive_arg (arg : types) (c : proof_cat) : proof_cat = (apply_functor (fun o -> ret o) (fun m -> - map_if - (map_ext_arrow (fun _ -> bound)) - (snd (maps_to t m Evd.empty)) - m) + ret + (map_if + (map_ext_arrow (fun _ -> bound)) + (snd (maps_to t m Evd.empty)) + m)) c Evd.empty) @@ -674,7 +682,7 @@ let sub_property_params npms pms pb c : proof_cat = snd (apply_functor (fun o -> ret (sub_obj_property_params pi pb pms_subs_shift ds o)) - (sub_arr_property_params pi pb pms_subs_shift ds) + (fun a -> ret (sub_arr_property_params pi pb pms_subs_shift ds a)) c Evd.empty) diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index 18bf1e5..051665f 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -163,7 +163,7 @@ val substitute_terminal : proof_cat -> proof_cat -> evar_map -> proof_cat state * Assumes that the destination has an initial object * Assumes contexts are not equal (creates fresh identifiers) *) -val substitute_categories : proof_cat -> proof_cat -> proof_cat +val substitute_categories : proof_cat -> proof_cat -> evar_map -> proof_cat state (* * Find the context where the shortest path is a given length From 3d875a51badfa848c865ff19a814607e94d3fc05 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:45:54 -0700 Subject: [PATCH 093/154] substitute_categories better version --- .../categories/proofcatterms.ml | 32 +++++++++---------- 1 file changed, 15 insertions(+), 17 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 778e536..ea19c31 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -389,24 +389,22 @@ let substitute_terminal (c : proof_cat) (exp : proof_cat) = * Assumes that sc has a terminal object and dc has an initial object * Creates fresh IDs for dc first to make sure we don't get repetition *) -let substitute_categories (sc : proof_cat) (dc : proof_cat) sigma = - let sigma, dcf = make_all_fresh dc sigma in - let t = terminal sc in - let i = initial dcf in +let substitute_categories (sc : proof_cat) (dc : proof_cat) = bind - (apply_functor - (fun o -> ret o) - (fun (src, e, dst) sigma_old -> - let sigma, src = - let sigma, eq = objects_equal i src sigma_old in - if eq then - sigma, t - else - sigma_old, src - in sigma, (src, e, dst)) - (snd (combine (initial_opt sc) (terminal_opt dcf) sc dcf sigma))) - (remove_object i) - sigma + (make_all_fresh dc) + (fun dcf -> + let t = terminal sc in + let i = initial dcf in + bind + (combine (initial_opt sc) (terminal_opt dcf) sc dcf) + (fun c -> + bind + (apply_functor + ret + (map_source_arrow + (branch_state (objects_equal i) (fun _ -> ret t) ret)) + c) + (remove_object i))) (* * Find all of the contexts in c where the shortest path is length i From eba5e8042aaad0d3bd372002aa49d3c5e03d7f35 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 14:51:59 -0700 Subject: [PATCH 094/154] contexts_at_index with state --- plugin/src/representation/categories/proofcatterms.ml | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index ea19c31..63ae24c 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -410,13 +410,14 @@ let substitute_categories (sc : proof_cat) (dc : proof_cat) = * Find all of the contexts in c where the shortest path is length i * Assumes c has an initial object *) -let contexts_at_index (c : proof_cat) (i : int) : context_object list = +let contexts_at_index (c : proof_cat) (i : int) = let rec find_at ms o n = if n = 0 then - [o] + ret [o] else - let _, adj = arrows_with_source o ms Evd.empty in - snd (flat_map_state (map_dest (fun d sigma -> sigma, find_at ms d (n - 1))) adj Evd.empty) + bind + (arrows_with_source o ms) + (flat_map_state (map_dest (fun d -> find_at ms d (n - 1)))) in find_at (morphisms c) (initial c) i (* @@ -425,7 +426,7 @@ let contexts_at_index (c : proof_cat) (i : int) : context_object list = * Assumes c has an initial object *) let context_at_index (c : proof_cat) (i : int) : context_object = - let ois = contexts_at_index c i in + let _, ois = contexts_at_index c i Evd.empty in assert ((List.length ois) = 1); List.hd ois From cab3502b21b67ab8fdf472809b7d443059ae11be Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 15:31:56 -0700 Subject: [PATCH 095/154] merge_up_to_index evar_maps --- plugin/src/compilation/expansion.ml | 2 +- .../categories/proofcatterms.ml | 58 +++++++++++++------ .../categories/proofcatterms.mli | 9 +-- 3 files changed, 41 insertions(+), 28 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 4537419..f7cb397 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -231,7 +231,7 @@ let applies_ih (env : env) (evd : evar_map) (p : types) (c : proof_cat) (o : con * So we should test for that case *) let bind_ihs (c : proof_cat) : proof_cat = - let env_with_p = context_env (context_at_index c 1) in + let env_with_p = context_env (snd (context_at_index c 1 Evd.empty)) in let (_, _, p) = CRD.to_tuple @@ lookup_rel 1 env_with_p in let env = pop_rel_context 1 env_with_p in snd diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 63ae24c..56965f9 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -425,10 +425,12 @@ let contexts_at_index (c : proof_cat) (i : int) = * Errors if more than one such context exists * Assumes c has an initial object *) -let context_at_index (c : proof_cat) (i : int) : context_object = - let _, ois = contexts_at_index c i Evd.empty in - assert ((List.length ois) = 1); - List.hd ois +let context_at_index (c : proof_cat) (i : int) = + bind + (contexts_at_index c i) + (fun ois -> + assert ((List.length ois) = 1); + ret (List.hd ois)) (* * Merge the first n contexts, and from there on out, include everything from both c1 and c2 @@ -437,30 +439,48 @@ let context_at_index (c : proof_cat) (i : int) : context_object = * Assumes the first n contexts are equal * Assumes c1 and c2 both have initial contexs *) -let merge_first_n (n : int) (c1 : proof_cat) (c2 : proof_cat) : proof_cat = +let merge_first_n (n : int) (c1 : proof_cat) (c2 : proof_cat) sigma = assert (n > 0); - let end1 = context_at_index c1 (n - 1) in - let end2 = context_at_index c2 (n - 1) in - let _, path2 = arrows_from c2 end2 Evd.empty in - let os2 = conclusions path2 in - let _, ms2 = map_state (map_source_arrow (fun o sigma -> sigma, map_if (fun _ -> end1) (snd (objects_equal end2 o sigma)) o)) path2 Evd.empty in - let os = List.append (snd (objects c1 Evd.empty)) os2 in + let sigma, end1 = context_at_index c1 (n - 1) sigma in + let sigma, end2 = context_at_index c2 (n - 1) sigma in + let sigma, (os2, ms2) = + bind + (arrows_from c2 end2) + (fun path2 -> + bind + (map_state + (map_source_arrow + (branch_state (objects_equal end2) (fun _ -> ret end1) ret)) + path2) + (fun ms2 -> ret (conclusions path2, ms2))) + sigma + in + let sigma, (os1, ms1) = + bind + (objects c1) + (fun os1 -> ret (os1, morphisms c1)) + sigma + in + let os = List.append os1 os2 in let ms = List.append (morphisms c1) ms2 in - snd (make_category os ms (initial_opt c1) None Evd.empty) + make_category os ms (initial_opt c1) None sigma (* * Assume the first n objects in c are equal, and merge * any objects at that index * Assume c has an initial object *) -let merge_up_to_index (n : int) (c : proof_cat) : proof_cat = +let merge_up_to_index (n : int) (c : proof_cat) = if n <= 1 then - c + ret c else let i = initial c in - let _, ps = paths_from c i Evd.empty in - let cs = List.map (fun ms -> snd (make_category (i :: conclusions ms) ms (Some i) None Evd.empty)) ps in - List.fold_left (merge_first_n n) (List.hd cs) (List.tl cs) + bind + (bind + (paths_from c i) + (map_state + (fun ms -> make_category (i :: conclusions ms) ms (Some i) None))) + (fun cs -> fold_left_state (merge_first_n n) (List.hd cs) (List.tl cs)) (* * Merge the conclusions for a non-recursive inductive type @@ -487,7 +507,7 @@ let merge_conclusions_nonrec (c : proof_cat) : proof_cat = * Otherwise, merge the n parameters and also the conclusions *) let merge_inductive (is_rec : bool) (n : int) (c : proof_cat) : proof_cat = - let merged_params_c = merge_up_to_index (n + 1) c in + let _, merged_params_c = merge_up_to_index (n + 1) c Evd.empty in if is_rec then merged_params_c else @@ -692,7 +712,7 @@ let sub_property_params npms pms pb c : proof_cat = *) let bind_property_and_params (po : types option) (pms : types list) (npms : int) (c : proof_cat) : proof_cat = let ms = morphisms c in - let p_unbound = List.find (fun m -> snd (maps_to (context_at_index c (npms + 1)) m Evd.empty)) ms in + let p_unbound = List.find (fun m -> snd (maps_to (snd (context_at_index c (npms + 1) Evd.empty)) m Evd.empty)) ms in let po_shift = Option.map (shift_by npms) po in let p_bound = bind_property_arrow po_shift p_unbound in let (last_param, p_binding, _) = p_bound in diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index 051665f..ad0857c 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -170,14 +170,7 @@ val substitute_categories : proof_cat -> proof_cat -> evar_map -> proof_cat stat * Errors if more than one such context exists * Assumes there is an initial object *) -val context_at_index : proof_cat -> int -> context_object - -(* - * Assume the first n objects in a category are equal, and merge - * any objects at that index - * Assume the category has an initial object - *) -val merge_up_to_index : int -> proof_cat -> proof_cat +val context_at_index : proof_cat -> int -> evar_map -> context_object state (* * Merge an inductive type From fe6f7e28afe665d7343b3bf68779b205e50e2743 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 15:43:05 -0700 Subject: [PATCH 096/154] merge_inductive state --- .../categories/proofcatterms.ml | 40 ++++++++++++------- .../categories/proofcatterms.mli | 2 +- 2 files changed, 26 insertions(+), 16 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 56965f9..08b8fed 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -491,27 +491,37 @@ let merge_up_to_index (n : int) (c : proof_cat) = * * So revisit this later. So far we haven't needed it. *) -let merge_conclusions_nonrec (c : proof_cat) : proof_cat = - let non_assums = List.filter (fun m -> snd (map_dest (is_not_hypothesis c) m Evd.empty)) (morphisms c) in - match conclusions non_assums with - | h :: t -> - let _, os = all_objects_except_those_in t (snd (objects c Evd.empty)) Evd.empty in - let merge_h_t o sigma = map_if (fun _ -> sigma, h) (snd (contains_object o t Evd.empty)) (sigma, o) in - let _, ms = map_arrows (map_state (map_dest_arrow merge_h_t)) c Evd.empty in - snd (make_category os ms (initial_opt c) (Some h) Evd.empty) - | [] -> c +let merge_conclusions_nonrec (c : proof_cat) = + bind + (filter_state (map_dest (is_not_hypothesis c)) (morphisms c)) + (fun non_assums -> + match conclusions non_assums with + | h :: t -> + let merge_h_t = + branch_state (fun o -> contains_object o t) (fun _ -> ret h) ret + in + bind + (bind (objects c) (all_objects_except_those_in t)) + (fun os -> + bind + (map_arrows (map_state (map_dest_arrow merge_h_t)) c) + (fun ms -> make_category os ms (initial_opt c) (Some h))) + | [] -> + ret c) (* * Merge an inductive type * If is_rec, just merge the parameters * Otherwise, merge the n parameters and also the conclusions *) -let merge_inductive (is_rec : bool) (n : int) (c : proof_cat) : proof_cat = - let _, merged_params_c = merge_up_to_index (n + 1) c Evd.empty in - if is_rec then - merged_params_c - else - merge_conclusions_nonrec merged_params_c +let merge_inductive (is_rec : bool) (n : int) (c : proof_cat) = + bind + (merge_up_to_index (n + 1) c) + (fun merged_params_c -> + if is_rec then + ret merged_params_c + else + merge_conclusions_nonrec merged_params_c) (* --- Binding --- *) diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index ad0857c..f6ab1eb 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -179,7 +179,7 @@ val context_at_index : proof_cat -> int -> evar_map -> context_object state * If the type is recursive, just merge the parameters * Otherwise, merge the parameters and also the conclusions *) -val merge_inductive : bool -> int -> proof_cat -> proof_cat +val merge_inductive : bool -> int -> proof_cat -> evar_map -> proof_cat state (* --- Binding --- *) From 2cd083271d88ec3a82adf4e234cc47f8bb21d04f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 16:29:21 -0700 Subject: [PATCH 097/154] Attempt at more refactoring, but broke something --- plugin/src/compilation/evaluation.ml | 6 +- plugin/src/compilation/expansion.ml | 16 +- .../categories/proofcatterms.ml | 175 ++++++++++-------- .../categories/proofcatterms.mli | 8 +- 4 files changed, 114 insertions(+), 91 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 99fbe9e..324530b 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -37,7 +37,7 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = let eval_theorem_bind (e : extension) (env : env) (typ : types) : proof_cat = let t = Context (Term (typ, env), (fid ())) in let _, c = set_terminal (Some t) (snd (add_object t (snd (initial_category Evd.empty)) Evd.empty)) Evd.empty in - bind c (initial_context, e, t) + snd (bind_cat c (initial_context, e, t) Evd.empty) (* Evaluate an anonymous proof of typ one step *) let eval_theorem (env : env) (typ : types) : proof_cat = @@ -119,7 +119,7 @@ let bind_constrs_to_args fc cs ncs arg_partition = let non_params = Array.of_list arg_partition.non_params in let num_non_params = Array.length non_params in let cs_params = Array.of_list (List.map (fun c -> snd (substitute_terminal fc c Evd.empty)) cs) in - let cs_args = Array.to_list (bind_inductive_args non_params cs_params) in + let cs_args = Array.to_list (snd (bind_inductive_args non_params cs_params Evd.empty)) in let cs_no_args = List.map (Array.get cs_params) (range num_non_params (List.length cs)) in List.append cs_args cs_no_args @@ -149,7 +149,7 @@ let eval_induction (mutind_body : mutual_inductive_body) (fc : proof_cat) (args let c = combine_constrs fc cs_bound in let property = arg_partition.property in let params = arg_partition.params in - let c_bound = bind_property_and_params property params npms c in + let _, c_bound = bind_property_and_params property params npms c Evd.empty in (c_bound, npms, arg_partition.final_args) else (fc, npms, []) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index f7cb397..7687c43 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -49,7 +49,7 @@ let expand_product (env : env) ((n, t, b) : Name.t * types * types) : proof_cat let env' = push_rel CRD.(LocalAssum(n, t)) env in let b' = eval_theorem env' b in let _, c = substitute_categories t' b' Evd.empty in - bind c (initial c, LazyBinding (mkRel 1, env'), terminal t') + snd (bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t') Evd.empty) (* Expand a lambda term exactly once *) let expand_lambda (env : env) ((n, t, b) : Name.t * types * types) : proof_cat = @@ -88,7 +88,7 @@ let expand_app (env : env) ((f, args) : types * types array) = let arg = args.(0) in let f' = eval_proof env (mkApp (f, Array.make 1 arg)) in let _, arg' = substitute_categories (eval_proof env arg) f' Evd.empty in - bind_apply_function (LazyBinding (f, env)) 1 arg' + snd (bind_apply_function (LazyBinding (f, env)) 1 arg' Evd.empty) (* --- Contexts --- *) @@ -128,7 +128,7 @@ let expand_product_fully (o : context_object) : proof_cat = let env' = push_rel CRD.(LocalAssum(n, t)) env in let b'' = expand_fully env' (n', t', b') in let _, c = substitute_categories t'' b'' Evd.empty in - bind c (initial c, LazyBinding (mkRel 1, env'), terminal t'') + snd (bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t'') Evd.empty) | _ -> expand_product env (n, t, b) in expand_fully (context_env o) (destProd (fst (dest_context_term o))) @@ -178,10 +178,12 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = let dc = expand_product_fully d in let map_i_to_src m sigma = sigma, if (snd (objects_equal (initial dc) m Evd.empty)) then s else m in let arity = (List.length (morphisms dc)) - 1 in - bind_apply_function - (shift_ext_by arity (substitute_ext_env (context_env (terminal dc)) e)) - arity - (snd (apply_functor map_i_to_src (map_source_arrow map_i_to_src) dc Evd.empty))) + snd + (bind_apply_function + (shift_ext_by arity (substitute_ext_env (context_env (terminal dc)) e)) + arity + (snd (apply_functor map_i_to_src (map_source_arrow map_i_to_src) dc Evd.empty)) + Evd.empty)) ms (* diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 08b8fed..91be961 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -529,27 +529,30 @@ let merge_inductive (is_rec : bool) (n : int) (c : proof_cat) = * Bind an arrow from src to dst of m in c with extension e of m * If an arrow with an anonymous binding exists, then bind that arrow * Otherwise, add the arrow if it doesn't exist - * - * TODO rename! *) -let bind (c : proof_cat) (m : arrow) : proof_cat = +let bind_cat (c : proof_cat) (m : arrow) sigma = let (src, e, dst) = m in - let t = if snd (is_terminal c src Evd.empty) then Some dst else terminal_opt c in - let i = if snd (is_initial c dst Evd.empty) then Some src else initial_opt c in - let _, c' = - apply_functor - (fun o -> ret o) - (fun m' -> - if snd (arrows_equal (src, AnonymousBinding, dst) m' Evd.empty) then - ret m - else - ret m') - c - Evd.empty - in map_if - (fun c' -> snd (set_initial_terminal i t (snd (add_arrow m c' Evd.empty)) Evd.empty)) - (not (snd (category_contains_arrow m c' Evd.empty))) - c' + let get_i_t is_i_t o1 o2 i_t_opt = + branch_state + (fun c -> is_i_t c o1) + (fun _ -> ret (Some o2)) + (fun c -> ret (i_t_opt c)) + in + let sigma, t = get_i_t is_terminal src dst terminal_opt c sigma in + let sigma, i = get_i_t is_initial dst src initial_opt c sigma in + bind + (apply_functor + ret + (branch_state + (arrows_equal (src, AnonymousBinding, dst)) + (fun _ -> ret m) + ret) + c) + (branch_state + (category_contains_arrow m) + (fun c -> bind (add_arrow m c) (set_initial_terminal i t)) + ret) + sigma (* @@ -557,66 +560,69 @@ let bind (c : proof_cat) (m : arrow) : proof_cat = * The extension e holds the function before it is applied * Apply that to the n most recent local bindings *) -let bind_apply_function (e : extension) (n : int) (c : proof_cat) : proof_cat = +let bind_apply_function (e : extension) (n : int) (c : proof_cat) = let args = List.rev (List.map (fun i -> Index i) (from_one_to n)) in let binding = List.fold_left (fun b r -> AppBinding (b, r)) e args in - snd - (apply_functor - (fun o -> ret o) - (fun m -> - ret - (map_if - (fun (src, _, dst) -> (src, binding, dst)) - (snd (maps_to (terminal c) m Evd.empty)) - m)) - c - Evd.empty) + apply_functor + ret + (branch_state + (maps_to (terminal c)) + (fun (src, _, dst) -> ret (src, binding, dst)) + ret) + c (* Bind an inductive argument arg to the end of c *) -let bind_inductive_arg (arg : types) (c : proof_cat) : proof_cat = +let bind_inductive_arg (arg : types) (c : proof_cat) = let t = terminal c in let bound = ext_of_term (context_env t) arg in - snd - (apply_functor - (fun o -> ret o) - (fun m -> - ret - (map_if - (map_ext_arrow (fun _ -> bound)) - (snd (maps_to t m Evd.empty)) - m)) - c - Evd.empty) + apply_functor + ret + (branch_state + (maps_to t) + (fun m -> ret (map_ext_arrow (fun _ -> bound) m)) + ret) + c (* Bind an array of inductive arguments args to each category in cs *) -let bind_inductive_args (args : types array) (cs : proof_cat array) : proof_cat array = - Array.mapi - (fun i arg -> +let bind_inductive_args (args : types array) (cs : proof_cat array) = + map_state_array + (fun (i, arg) -> let c = cs.(i) in - let _, t_index = shortest_path_length c (terminal c) Evd.empty in - bind_inductive_arg (shift_by (t_index - 1) arg) c) - args + bind + (shortest_path_length c (terminal c)) + (fun t_index -> bind_inductive_arg (shift_by (t_index - 1) arg) c)) + (Array.mapi (fun i arg -> (i, arg)) args) (* * Auxiliary function for binding properties and parameters * Get the arrow for binding an optional property *) -let bind_property_arrow (po : types option) (m : arrow) : arrow = - let _, env = map_dest (fun o -> ret (context_env o)) m Evd.empty in - map_ext_arrow (fun e -> Option.default e (Option.map (ext_of_term env) po)) m +let bind_property_arrow (po : types option) (m : arrow) = + bind + (map_dest (fun o -> ret (context_env o)) m) + (fun env -> + ret + (map_ext_arrow + (fun e -> Option.default e (Option.map (ext_of_term env) po)) + m)) (* * Auxiliary function for binding properties and parameters * Get the arrows for binding a list of parameters *) -let bind_param_arrows (ps : types list) (ms : arrow list) : arrow list = - let _, envs = map_state (map_dest (fun o -> ret (context_env o))) ms Evd.empty in - let envs = Array.of_list envs in - let pes = Array.of_list (List.mapi (fun i p -> ext_of_term envs.(i) p) ps) in - List.mapi - (fun i m -> - map_ext_arrow (fun e -> if i < Array.length pes then pes.(i) else e) m) - ms +let bind_param_arrows (ps : types list) (ms : arrow list) = + bind + (map_state (map_dest (fun o -> ret (context_env o))) ms) + (fun envs -> + let envs = Array.of_list envs in + let pes = Array.of_list (List.mapi (fun i p -> ext_of_term envs.(i) p) ps) in + ret + (List.mapi + (fun i m -> + map_ext_arrow + (fun e -> if i < Array.length pes then pes.(i) else e) + m) + ms)) (* * Auxiliary function for binding properties and parameters @@ -699,38 +705,53 @@ let sub_arr_property_params pi pb subs ds m = * Auxiliary function for binding properties and parameters * Substitute a property and parameters into an a category c. *) -let sub_property_params npms pms pb c : proof_cat = - let _, os = objects c Evd.empty in - let ds = List.map (fun o -> (context_index o, snd (shortest_path_length c o Evd.empty))) os in +let sub_property_params npms pms pb c = let pms_es = List.map (map_ext ext_term) pms in let pms_shift = List.mapi (fun j t -> shift_by_unconditional (- (npms - j)) t) pms_es in let pms_shift_rev = List.rev pms_shift in let pms_subs = build_n_substitutions npms pms_shift_rev no_substitutions in let pi = npms + 1 in let pms_subs_shift = unshift_from_substitutions_by pi pms_subs in - snd - (apply_functor - (fun o -> ret (sub_obj_property_params pi pb pms_subs_shift ds o)) - (fun a -> ret (sub_arr_property_params pi pb pms_subs_shift ds a)) - c - Evd.empty) + bind + (bind + (objects c) + (map_state + (fun o -> + bind + (shortest_path_length c o) + (fun n -> ret (context_index o, n))))) + (fun ds -> + apply_functor + (fun o -> ret (sub_obj_property_params pi pb pms_subs_shift ds o)) + (fun a -> ret (sub_arr_property_params pi pb pms_subs_shift ds a)) + c) (* * Bind an inductive property p and parameters pms in c * c is a proof category for an inductive proof * npms is the total number of possible parameters *) -let bind_property_and_params (po : types option) (pms : types list) (npms : int) (c : proof_cat) : proof_cat = +let bind_property_and_params (po : types option) (pms : types list) (npms : int) (c : proof_cat) sigma = let ms = morphisms c in - let p_unbound = List.find (fun m -> snd (maps_to (snd (context_at_index c (npms + 1) Evd.empty)) m Evd.empty)) ms in + let sigma, p_unbound = + bind + (context_at_index c (npms + 1)) + (fun o -> find_state (maps_to o) ms) + sigma + in let po_shift = Option.map (shift_by npms) po in - let p_bound = bind_property_arrow po_shift p_unbound in + let sigma, p_bound = bind_property_arrow po_shift p_unbound sigma in let (last_param, p_binding, _) = p_bound in - let _, pms_unbound = arrows_between c (initial c) last_param Evd.empty in + let sigma, pms_unbound = arrows_between c (initial c) last_param sigma in let pms_shift = List.mapi (fun i p -> shift_by_unconditional (npms - i - 1) p) pms in - let pms_bound = bind_param_arrows pms_shift pms_unbound in - let _, ms_old = all_arrows_except_those_in (p_unbound :: pms_unbound) ms Evd.empty in + let sigma, pms_bound = bind_param_arrows pms_shift pms_unbound sigma in + let sigma, ms_old = all_arrows_except_those_in (p_unbound :: pms_unbound) ms sigma in let ms' = List.append pms_bound (p_bound :: ms_old) in - let _, c' = make_category (snd (objects c Evd.empty)) ms' (initial_opt c) (terminal_opt c) Evd.empty in - sub_property_params npms pms_bound p_binding c' + bind + (objects c) + (fun os' -> + bind + (make_category os' ms' (initial_opt c) (terminal_opt c)) + (sub_property_params npms pms_bound p_binding)) + sigma diff --git a/plugin/src/representation/categories/proofcatterms.mli b/plugin/src/representation/categories/proofcatterms.mli index f6ab1eb..d9583f3 100644 --- a/plugin/src/representation/categories/proofcatterms.mli +++ b/plugin/src/representation/categories/proofcatterms.mli @@ -189,21 +189,21 @@ val merge_inductive : bool -> int -> proof_cat -> evar_map -> proof_cat state * then substitute the provided extension * Otherwise, add the new binding *) -val bind : proof_cat -> arrow -> proof_cat +val bind_cat : proof_cat -> arrow -> evar_map -> proof_cat state (* * Build a function application for the last extension in a proof category * The provided extension holds the function before it is applied * Apply that to the provided number most recent local bindings *) -val bind_apply_function : extension -> int -> proof_cat -> proof_cat +val bind_apply_function : extension -> int -> proof_cat -> evar_map -> proof_cat state (* * Bind an array of arguments to each category in an array of categories, * where each category in the array is an inductive constructor, * and each argument is an argument to the respective constructor *) -val bind_inductive_args : types array -> proof_cat array -> proof_cat array +val bind_inductive_args : types array -> proof_cat array -> evar_map -> (proof_cat array) state (* * Bind an inductive property and inductive parameters @@ -212,5 +212,5 @@ val bind_inductive_args : types array -> proof_cat array -> proof_cat array * Pass the total number of possible params in an int *) val bind_property_and_params : - types option -> types list -> int -> proof_cat -> proof_cat + types option -> types list -> int -> proof_cat -> evar_map -> proof_cat state From 4dd9b8a570f3e13004f59b10296a1dec6ac1ec1e Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 30 Aug 2019 16:36:26 -0700 Subject: [PATCH 098/154] fix the bug --- plugin/src/representation/categories/proofcatterms.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index 91be961..e0e41e4 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -550,8 +550,8 @@ let bind_cat (c : proof_cat) (m : arrow) sigma = c) (branch_state (category_contains_arrow m) - (fun c -> bind (add_arrow m c) (set_initial_terminal i t)) - ret) + ret + (fun c -> bind (add_arrow m c) (set_initial_terminal i t))) sigma From ee6656e4105f7574bde7162a393486aa627d4f95 Mon Sep 17 00:00:00 2001 From: tringer Date: Sun, 1 Sep 2019 18:05:39 -0700 Subject: [PATCH 099/154] broken, but time to play portal --- plugin/src/compilation/evaluation.ml | 17 +++++++++++------ plugin/src/compilation/evaluation.mli | 4 +++- 2 files changed, 14 insertions(+), 7 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 324530b..2eea96e 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -18,6 +18,9 @@ open Contextutils * Infer the type of trm in env * Note: This does not yet use good evar map hygeine; will fix that * during the refactor. + * + * TODO remove this last. Will likely need good evar discipline everywhere + * else first. But can try. *) let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in @@ -34,19 +37,21 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = * Evaluate typ one step in env * Then bind the single anonymous arrow to e *) -let eval_theorem_bind (e : extension) (env : env) (typ : types) : proof_cat = +let eval_theorem_bind (e : extension) (env : env) (typ : types) sigma = let t = Context (Term (typ, env), (fid ())) in - let _, c = set_terminal (Some t) (snd (add_object t (snd (initial_category Evd.empty)) Evd.empty)) Evd.empty in - snd (bind_cat c (initial_context, e, t) Evd.empty) + let sigma, c = initial_category sigma in + let sigma, c = add_object t c sigma in + let sigma, c = set_terminal (Some t) c sigma in + bind_cat c (initial_context, e, t) sigma (* Evaluate an anonymous proof of typ one step *) let eval_theorem (env : env) (typ : types) : proof_cat = - eval_theorem_bind AnonymousBinding env typ + snd (eval_theorem_bind AnonymousBinding env typ Evd.empty) (* Evaluate a proof trm one step *) let eval_proof (env : env) (trm : types) : proof_cat = let typ = infer_type env Evd.empty trm in - eval_theorem_bind (ext_of_term env trm) env typ + snd (eval_theorem_bind (ext_of_term env trm) env typ Evd.empty) (* Evaluate an arrow as a proof *) let eval_proof_arrow (m : arrow) : proof_cat = @@ -67,7 +72,7 @@ let rec induction_constrs (nc : int) (env : env) ((n, t, b) : Name.t * types * t [] else let e = LazyBinding (mkRel 1, push_rel CRD.(LocalAssum(n, t)) env) in - let c = eval_theorem_bind e env t in + let c = snd (eval_theorem_bind e env t Evd.empty) in match kind b with | Prod (n', t', b') -> let d = List.length (morphisms c) in diff --git a/plugin/src/compilation/evaluation.mli b/plugin/src/compilation/evaluation.mli index c42a41c..d823fb1 100644 --- a/plugin/src/compilation/evaluation.mli +++ b/plugin/src/compilation/evaluation.mli @@ -4,12 +4,14 @@ open Constr open Environ open Proofcat open Declarations +open Stateutils +open Evd (* * Evaluate a term one step in an environment * Then bind the single anonymous arrow to the extension *) -val eval_theorem_bind : extension -> env -> types -> proof_cat +val eval_theorem_bind : extension -> env -> types -> evar_map -> proof_cat state (* Evaluate an anonymous proof (inhabitant) of a theorem (type) one step *) val eval_theorem : env -> types -> proof_cat From d9e5770554b9c5e61b04e9cc86bdc258344c73ab Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 12:22:02 -0700 Subject: [PATCH 100/154] Fix build error --- plugin/src/compilation/expansion.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 7687c43..4ad45dc 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -152,7 +152,7 @@ let expand_terminal (c : proof_cat) : proof_cat = else AnonymousBinding in - let exp = expand_term (eval_theorem_bind binding) t in + let exp = expand_term (fun env t -> snd (eval_theorem_bind binding env t Evd.empty)) t in snd (substitute_terminal c exp Evd.empty) | _ -> c From b6d1d8e2906841b32e80af4802f2a2ab92d04b9f Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 12:26:26 -0700 Subject: [PATCH 101/154] monads for eval_theorem_bind --- plugin/src/compilation/evaluation.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 2eea96e..ba60d40 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -11,6 +11,7 @@ open Debruijn open Declarations open Indutils open Contextutils +open Stateutils (* --- TODO for refactoring without breaking things --- *) @@ -37,12 +38,11 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = * Evaluate typ one step in env * Then bind the single anonymous arrow to e *) -let eval_theorem_bind (e : extension) (env : env) (typ : types) sigma = +let eval_theorem_bind (e : extension) (env : env) (typ : types) = let t = Context (Term (typ, env), (fid ())) in - let sigma, c = initial_category sigma in - let sigma, c = add_object t c sigma in - let sigma, c = set_terminal (Some t) c sigma in - bind_cat c (initial_context, e, t) sigma + bind + (bind (bind initial_category (add_object t)) (set_terminal (Some t))) + (fun c -> bind_cat c (initial_context, e, t)) (* Evaluate an anonymous proof of typ one step *) let eval_theorem (env : env) (typ : types) : proof_cat = From b503cb3bd4db309046ceb2551a8af90d2fd91908 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 12:36:58 -0700 Subject: [PATCH 102/154] other evaluation functions --- plugin/src/compilation/evaluation.ml | 16 ++++++++-------- plugin/src/compilation/evaluation.mli | 6 +++--- plugin/src/compilation/expansion.ml | 18 +++++++++--------- plugin/src/compilation/proofdiff.ml | 2 +- .../components/differencing/inddifferencers.ml | 4 ++-- plugin/src/patcher.ml4 | 6 +++--- 6 files changed, 26 insertions(+), 26 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index ba60d40..d0f6023 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -23,9 +23,9 @@ open Stateutils * TODO remove this last. Will likely need good evar discipline everywhere * else first. But can try. *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = +let infer_type (env : env) (evd : evar_map) (trm : types) = let jmt = Typeops.infer env trm in - j_type jmt + evd, j_type jmt (* --- End TODO --- *) @@ -45,16 +45,16 @@ let eval_theorem_bind (e : extension) (env : env) (typ : types) = (fun c -> bind_cat c (initial_context, e, t)) (* Evaluate an anonymous proof of typ one step *) -let eval_theorem (env : env) (typ : types) : proof_cat = - snd (eval_theorem_bind AnonymousBinding env typ Evd.empty) +let eval_theorem (env : env) (typ : types) = + eval_theorem_bind AnonymousBinding env typ (* Evaluate a proof trm one step *) -let eval_proof (env : env) (trm : types) : proof_cat = - let typ = infer_type env Evd.empty trm in - snd (eval_theorem_bind (ext_of_term env trm) env typ Evd.empty) +let eval_proof (env : env) (trm : types) sigma = + let sigma, typ = infer_type env sigma trm in + eval_theorem_bind (ext_of_term env trm) env typ sigma (* Evaluate an arrow as a proof *) -let eval_proof_arrow (m : arrow) : proof_cat = +let eval_proof_arrow (m : arrow) = let (_, e, dst) = m in eval_proof (context_env dst) (ext_term e) diff --git a/plugin/src/compilation/evaluation.mli b/plugin/src/compilation/evaluation.mli index d823fb1..628c126 100644 --- a/plugin/src/compilation/evaluation.mli +++ b/plugin/src/compilation/evaluation.mli @@ -14,13 +14,13 @@ open Evd val eval_theorem_bind : extension -> env -> types -> evar_map -> proof_cat state (* Evaluate an anonymous proof (inhabitant) of a theorem (type) one step *) -val eval_theorem : env -> types -> proof_cat +val eval_theorem : env -> types -> evar_map -> proof_cat state (* Evaluate a proof (term) one step *) -val eval_proof : env -> types -> proof_cat +val eval_proof : env -> types -> evar_map -> proof_cat state (* Evaluate an arrow as a proof *) -val eval_proof_arrow : arrow -> proof_cat +val eval_proof_arrow : arrow -> evar_map -> proof_cat state (* * Evaluate an inductive proof given: diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 4ad45dc..fdbff40 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -45,9 +45,9 @@ type 'a expansion_strategy = 'a -> 'a (* Expand a product type exactly once *) let expand_product (env : env) ((n, t, b) : Name.t * types * types) : proof_cat = - let t' = eval_theorem env t in + let _, t' = eval_theorem env t Evd.empty in let env' = push_rel CRD.(LocalAssum(n, t)) env in - let b' = eval_theorem env' b in + let _, b' = eval_theorem env' b Evd.empty in let _, c = substitute_categories t' b' Evd.empty in snd (bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t') Evd.empty) @@ -70,7 +70,7 @@ let expand_inductive (env : env) (((i, ii), u) : pinductive) : proof_cat = (fun ci -> mkConstructU (((i, ii), ci), u)) (from_one_to (Array.length body.mind_consnames)) in - let cs = List.map (eval_proof env_ind) constrs in + let cs = List.map (fun t -> snd (eval_proof env_ind t Evd.empty)) constrs in List.fold_left (fun cind c -> let os = (terminal c) :: (snd (objects cind Evd.empty)) in @@ -86,8 +86,8 @@ let expand_inductive (env : env) (((i, ii), u) : pinductive) : proof_cat = let expand_app (env : env) ((f, args) : types * types array) = assert (Array.length args > 0); let arg = args.(0) in - let f' = eval_proof env (mkApp (f, Array.make 1 arg)) in - let _, arg' = substitute_categories (eval_proof env arg) f' Evd.empty in + let _, f' = eval_proof env (mkApp (f, Array.make 1 arg)) Evd.empty in + let _, arg' = substitute_categories (snd (eval_proof env arg Evd.empty)) f' Evd.empty in snd (bind_apply_function (LazyBinding (f, env)) 1 arg' Evd.empty) (* --- Contexts --- *) @@ -124,7 +124,7 @@ let expand_product_fully (o : context_object) : proof_cat = let rec expand_fully env (n, t, b) = match kind b with | Prod (n', t', b') -> - let t'' = eval_theorem env t in + let _, t'' = eval_theorem env t Evd.empty in let env' = push_rel CRD.(LocalAssum(n, t)) env in let b'' = expand_fully env' (n', t', b') in let _, c = substitute_categories t'' b'' Evd.empty in @@ -268,11 +268,11 @@ let expand_const_app env (c, u) (f, args) default = match inductive_of_elim env (c, u) with | Some mutind -> let mutind_body = lookup_mind mutind env in - let f_c = eval_proof env f in + let _, f_c = eval_proof env f Evd.empty in let f_exp = expand_inductive_params mutind_body.mind_nparams f_c in eval_induction mutind_body f_exp args | None -> - (eval_proof env (mkApp (f, args)), 0, default) + (snd (eval_proof env (mkApp (f, args)) Evd.empty), 0, default) (* * Expand an application arrow @@ -292,7 +292,7 @@ let expand_application (c, n, l) : proof_cat * int * (types list) = expand_const_app env (c, u) (f, args) l | _ -> let c_trm = Context (Term (trm, env), fid ()) in - let exp = expand_term eval_theorem c_trm in + let exp = expand_term (fun env t -> snd (eval_theorem env t Evd.empty)) c_trm in (exp, 0, l)) | _ -> assert false) (only_arrow c) diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index d386c35..45f4d31 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -149,7 +149,7 @@ let proof_to_term (d : goal_proof_diff) : goal_term_diff = let eval_with_term f g trm (d : goal_proof_diff) : goal_proof_diff = let (goal, _) = f d in let env = context_env goal in - g (goal, eval_proof env trm) d + g (goal, snd (eval_proof env trm Evd.empty)) d let eval_with_old_term = eval_with_term old_proof with_old_proof diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 991fd92..006181f 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -38,8 +38,8 @@ let rec diff_case abstract diff evd (d : goal_case_diff) : candidates = | ((h1 :: t1), (h2 :: t2)) -> let d_t = add_to_diff d_goal t1 t2 in (try - let c1 = eval_proof_arrow h1 in - let c2 = eval_proof_arrow h2 in + let _, c1 = eval_proof_arrow h1 Evd.empty in + let _, c2 = eval_proof_arrow h2 Evd.empty in let cs = abstract (diff evd (add_to_diff d_goal c1 c2)) in if non_empty cs then cs diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index f578f5a..c2e0611 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -82,8 +82,8 @@ let configure trm1 trm2 cut : goal_proof_diff * options = let (evm, env) = Pfedit.get_current_context() in let cut_term = Option.map (intern env evm) cut in let lemma = Option.map (fun evm, t -> build_cut_lemma env t) cut_term in - let c1 = eval_proof env trm1 in - let c2 = eval_proof env trm2 in + let _, c1 = eval_proof env trm1 Evd.empty in + let _, c2 = eval_proof env trm2 Evd.empty in let d = add_goals (difference c1 c2 no_assumptions) in let change = find_kind_of_change evm lemma d in (d, configure_search d change lemma) @@ -91,7 +91,7 @@ let configure trm1 trm2 cut : goal_proof_diff * options = (* Initialize diff & search configuration for optimization *) let configure_optimize trm : goal_proof_diff * options = let (evm, env) = Pfedit.get_current_context () in - let c = eval_proof env trm in + let _, c = eval_proof env trm Evd.empty in let d = add_goals (difference c c no_assumptions) in let change = Identity in (d, configure_search d change None) From 8841991bac0b7a1938b36669371a7bc295d98ddc Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 12:49:21 -0700 Subject: [PATCH 103/154] more evar_maps in evaluation --- plugin/src/compilation/evaluation.ml | 50 +++++++++++++++++----------- 1 file changed, 30 insertions(+), 20 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index d0f6023..30aaab7 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -67,19 +67,21 @@ let eval_proof_arrow (m : arrow) = * we have right now always works, even when constructors have many internal * foralls. *) -let rec induction_constrs (nc : int) (env : env) ((n, t, b) : Name.t * types * types) : proof_cat list = +let rec induction_constrs (nc : int) (env : env) ((n, t, b) : Name.t * types * types) = if nc = 0 then - [] + ret [] else let e = LazyBinding (mkRel 1, push_rel CRD.(LocalAssum(n, t)) env) in - let c = snd (eval_theorem_bind e env t Evd.empty) in - match kind b with - | Prod (n', t', b') -> - let d = List.length (morphisms c) in - let prod' = (n', unshift_by d t', unshift_by d b') in - c :: (induction_constrs (nc - 1) env prod') - | _ -> - [c] + bind + (eval_theorem_bind e env t) + (fun c -> + match kind b with + | Prod (n', t', b') -> + let d = List.length (morphisms c) in + let prod' = (n', unshift_by d t', unshift_by d b') in + bind (induction_constrs (nc - 1) env prod') (fun cs -> ret (c :: cs)) + | _ -> + ret [c]) (* * A partitition of arguments to an inductive proof into four parts: @@ -123,20 +125,28 @@ let partition_args (nparams : int) (nconstrs : int) (args : 'a list) : 'a argume let bind_constrs_to_args fc cs ncs arg_partition = let non_params = Array.of_list arg_partition.non_params in let num_non_params = Array.length non_params in - let cs_params = Array.of_list (List.map (fun c -> snd (substitute_terminal fc c Evd.empty)) cs) in - let cs_args = Array.to_list (snd (bind_inductive_args non_params cs_params Evd.empty)) in - let cs_no_args = List.map (Array.get cs_params) (range num_non_params (List.length cs)) in - List.append cs_args cs_no_args + bind + (map_state (substitute_terminal fc) cs) + (fun ps -> + let cs_params = Array.of_list ps in + bind + (bind_inductive_args non_params cs_params) + (fun args -> + let cs_args = Array.to_list args in + let cs_no_args = List.map (Array.get cs_params) (range num_non_params (List.length cs)) in + ret (List.append cs_args cs_no_args))) (* * Auxiliary function for eval_induction * Combine a list of constructors, defaulting to default * Assumes no terminal object *) -let combine_constrs (default : proof_cat) (cs : proof_cat list) : proof_cat = +let combine_constrs (default : proof_cat) (cs : proof_cat list) = match cs with - | h :: t -> List.fold_left (fun c1 c2 -> snd (combine (initial_opt h) None c1 c2 Evd.empty)) h t - | [] -> default + | h :: t -> + fold_left_state (combine (initial_opt h) None) h t + | [] -> + ret default (* * Evaluate an inductive proof @@ -149,9 +159,9 @@ let eval_induction (mutind_body : mutual_inductive_body) (fc : proof_cat) (args if context_is_product t then let ncs = num_constrs mutind_body in let arg_partition = partition_args npms ncs (Array.to_list args) in - let cs = induction_constrs ncs (context_env t) (context_as_product t) in - let cs_bound = bind_constrs_to_args fc cs ncs arg_partition in - let c = combine_constrs fc cs_bound in + let _, cs = induction_constrs ncs (context_env t) (context_as_product t) Evd.empty in + let _, cs_bound = bind_constrs_to_args fc cs ncs arg_partition Evd.empty in + let _, c = combine_constrs fc cs_bound Evd.empty in let property = arg_partition.property in let params = arg_partition.params in let _, c_bound = bind_property_and_params property params npms c Evd.empty in From 5ed1b47f20f7516d104665841bbe4c8a7b643172 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 13:01:31 -0700 Subject: [PATCH 104/154] eval_induction --- plugin/src/compilation/evaluation.ml | 20 +++++++++++++------- plugin/src/compilation/evaluation.mli | 2 +- plugin/src/compilation/expansion.ml | 2 +- 3 files changed, 15 insertions(+), 9 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 30aaab7..89c90e0 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -153,18 +153,24 @@ let combine_constrs (default : proof_cat) (cs : proof_cat list) = * Bind the arguments to the application of the induction principle * Return any leftover arguments after induction *) -let eval_induction (mutind_body : mutual_inductive_body) (fc : proof_cat) (args : types array) : proof_cat * int * types list = +let eval_induction (mutind_body : mutual_inductive_body) (fc : proof_cat) (args : types array) = let t = terminal fc in let npms = mutind_body.mind_nparams in if context_is_product t then let ncs = num_constrs mutind_body in let arg_partition = partition_args npms ncs (Array.to_list args) in - let _, cs = induction_constrs ncs (context_env t) (context_as_product t) Evd.empty in - let _, cs_bound = bind_constrs_to_args fc cs ncs arg_partition Evd.empty in - let _, c = combine_constrs fc cs_bound Evd.empty in let property = arg_partition.property in let params = arg_partition.params in - let _, c_bound = bind_property_and_params property params npms c Evd.empty in - (c_bound, npms, arg_partition.final_args) + bind + (induction_constrs ncs (context_env t) (context_as_product t)) + (fun cs -> + bind + (bind + (bind_constrs_to_args fc cs ncs arg_partition) + (combine_constrs fc)) + (fun c -> + bind + (bind_property_and_params property params npms c) + (fun c_bound -> ret (c_bound, npms, arg_partition.final_args)))) else - (fc, npms, []) + ret (fc, npms, []) diff --git a/plugin/src/compilation/evaluation.mli b/plugin/src/compilation/evaluation.mli index 628c126..38d71f7 100644 --- a/plugin/src/compilation/evaluation.mli +++ b/plugin/src/compilation/evaluation.mli @@ -33,4 +33,4 @@ val eval_proof_arrow : arrow -> evar_map -> proof_cat state * Return the number of params and any leftover arguments after induction *) val eval_induction : - mutual_inductive_body -> proof_cat -> types array -> proof_cat * int * types list + mutual_inductive_body -> proof_cat -> types array -> evar_map -> (proof_cat * int * types list) state diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index fdbff40..94fabc4 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -270,7 +270,7 @@ let expand_const_app env (c, u) (f, args) default = let mutind_body = lookup_mind mutind env in let _, f_c = eval_proof env f Evd.empty in let f_exp = expand_inductive_params mutind_body.mind_nparams f_c in - eval_induction mutind_body f_exp args + snd (eval_induction mutind_body f_exp args Evd.empty) | None -> (snd (eval_proof env (mkApp (f, args)) Evd.empty), 0, default) From f03c0cc65ec567c82c3ab4885c8c53cbaef466af Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 13:10:07 -0700 Subject: [PATCH 105/154] expand_product and expand_lambda evar_maps --- plugin/src/compilation/expansion.ml | 43 ++++++++++++++++------------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 94fabc4..9cbf750 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -13,6 +13,8 @@ open Debruijn open Declarations open Indutils open Contextutils +open Convertibility +open Envutils (* --- TODO for refactoring without breaking things --- *) @@ -20,20 +22,20 @@ open Contextutils * Infer the type of trm in env * Note: This does not yet use good evar map hygeine; will fix that * during the refactor. + * + * TODO remove this last, once good evar practice in all callers *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = +let infer_type (env : env) (evd : evar_map) (trm : types) : types state = let jmt = Typeops.infer env trm in - j_type jmt - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + evd, j_type jmt (* Check whether a term has a given type *) -let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool = +let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool state = try - let trm_typ = infer_type env evd trm in + let evd, trm_typ = infer_type env evd trm in convertible env evd trm_typ typ - with _ -> false + with _ -> + evd, false (* --- End TODO --- *) @@ -44,15 +46,18 @@ type 'a expansion_strategy = 'a -> 'a (* --- Terms and types --- *) (* Expand a product type exactly once *) -let expand_product (env : env) ((n, t, b) : Name.t * types * types) : proof_cat = - let _, t' = eval_theorem env t Evd.empty in - let env' = push_rel CRD.(LocalAssum(n, t)) env in - let _, b' = eval_theorem env' b Evd.empty in - let _, c = substitute_categories t' b' Evd.empty in - snd (bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t') Evd.empty) +let expand_product (env : env) ((n, t, b) : Name.t * types * types) = + bind + (eval_theorem env t) + (fun t' -> + let env' = push_local (n, t) env in + bind + (bind (eval_theorem env' b) (substitute_categories t')) + (fun c -> + bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t'))) (* Expand a lambda term exactly once *) -let expand_lambda (env : env) ((n, t, b) : Name.t * types * types) : proof_cat = +let expand_lambda (env : env) ((n, t, b) : Name.t * types * types) = expand_product env (n, t, b) (* @@ -101,9 +106,9 @@ let expand_term (default : env -> types -> proof_cat) (o : context_object) : pro let (trm, env) = dest_context_term o in match kind trm with | Prod (n, t, b) -> - expand_product env (n, t, b) + snd (expand_product env (n, t, b) Evd.empty) | Lambda (n, t, b) -> - expand_lambda env (n, t, b) + snd (expand_lambda env (n, t, b) Evd.empty) | Ind ((i, ii), u) -> expand_inductive env ((i, ii), u) | App (f, args) -> @@ -130,7 +135,7 @@ let expand_product_fully (o : context_object) : proof_cat = let _, c = substitute_categories t'' b'' Evd.empty in snd (bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t'') Evd.empty) | _ -> - expand_product env (n, t, b) + snd (expand_product env (n, t, b) Evd.empty) in expand_fully (context_env o) (destProd (fst (dest_context_term o))) (* --- Categories --- *) @@ -221,7 +226,7 @@ let applies_ih (env : env) (evd : evar_map) (p : types) (c : proof_cat) (o : con if context_is_app o then let (f, _) = context_as_app o in let f = unshift_by (snd (shortest_path_length c o Evd.empty)) f in - snd (is_hypothesis c o Evd.empty) && has_type env evd p f + snd (is_hypothesis c o Evd.empty) && snd (has_type env evd p f) else false From d69d68b3e92b145d058e1fca03672ef49086d6f5 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 13:17:15 -0700 Subject: [PATCH 106/154] expand_inductive and expand_app evar_maps --- plugin/src/compilation/expansion.ml | 34 +++++++++++++++++------------ 1 file changed, 20 insertions(+), 14 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 9cbf750..74c2b81 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -64,7 +64,7 @@ let expand_lambda (env : env) ((n, t, b) : Name.t * types * types) = * Expand an inductive type * This is unfinished, and currently unused for any benchmarks *) -let expand_inductive (env : env) (((i, ii), u) : pinductive) : proof_cat = +let expand_inductive (env : env) (((i, ii), u) : pinductive) = let mbody = lookup_mind i env in check_inductive_supported mbody; let bodies = mbody.mind_packets in @@ -75,14 +75,17 @@ let expand_inductive (env : env) (((i, ii), u) : pinductive) : proof_cat = (fun ci -> mkConstructU (((i, ii), ci), u)) (from_one_to (Array.length body.mind_consnames)) in - let cs = List.map (fun t -> snd (eval_proof env_ind t Evd.empty)) constrs in - List.fold_left - (fun cind c -> - let os = (terminal c) :: (snd (objects cind Evd.empty)) in - let ms = List.append (morphisms c) (morphisms cind) in - snd (make_category os ms (initial_opt cind) None Evd.empty)) - (List.hd cs) - (List.tl cs) + bind + (map_state (eval_proof env_ind) constrs) + (fun cs -> + fold_left_state + (fun cind c -> + let ms = List.append (morphisms c) (morphisms cind) in + bind + (bind (objects cind) (fun tl -> ret (terminal c :: tl))) + (fun os -> make_category os ms (initial_opt cind) None)) + (List.hd cs) + (List.tl cs)) (* * Expand application exactly once @@ -91,9 +94,12 @@ let expand_inductive (env : env) (((i, ii), u) : pinductive) : proof_cat = let expand_app (env : env) ((f, args) : types * types array) = assert (Array.length args > 0); let arg = args.(0) in - let _, f' = eval_proof env (mkApp (f, Array.make 1 arg)) Evd.empty in - let _, arg' = substitute_categories (snd (eval_proof env arg Evd.empty)) f' Evd.empty in - snd (bind_apply_function (LazyBinding (f, env)) 1 arg' Evd.empty) + bind + (eval_proof env (mkApp (f, Array.make 1 arg))) + (fun f' -> + bind + (bind (eval_proof env arg) (fun c -> substitute_categories c f')) + (bind_apply_function (LazyBinding (f, env)) 1)) (* --- Contexts --- *) @@ -110,13 +116,13 @@ let expand_term (default : env -> types -> proof_cat) (o : context_object) : pro | Lambda (n, t, b) -> snd (expand_lambda env (n, t, b) Evd.empty) | Ind ((i, ii), u) -> - expand_inductive env ((i, ii), u) + snd (expand_inductive env ((i, ii), u) Evd.empty) | App (f, args) -> (match kind f with | Lambda (n, t, b) -> (* Does not yet delta-reduce *) if Array.length args > 0 then - expand_app env (f, args) + snd (expand_app env (f, args) Evd.empty) else default env trm | _ -> From 257cf1120c7abc0df86e428c51cb105003a95efb Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 13:23:20 -0700 Subject: [PATCH 107/154] expand_term evar_maps --- plugin/src/compilation/expansion.ml | 16 ++++++++-------- plugin/src/compilation/expansion.mli | 9 ++------- 2 files changed, 10 insertions(+), 15 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 74c2b81..f46bc96 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -108,27 +108,27 @@ let expand_app (env : env) ((f, args) : types * types array) = * Default to using f when it cannot be expanded further * Error if the type context doesn't hold any terms *) -let expand_term (default : env -> types -> proof_cat) (o : context_object) : proof_cat = +let expand_term (default : env -> types -> evar_map -> proof_cat state) (o : context_object) = let (trm, env) = dest_context_term o in match kind trm with | Prod (n, t, b) -> - snd (expand_product env (n, t, b) Evd.empty) + expand_product env (n, t, b) | Lambda (n, t, b) -> - snd (expand_lambda env (n, t, b) Evd.empty) + expand_lambda env (n, t, b) | Ind ((i, ii), u) -> - snd (expand_inductive env ((i, ii), u) Evd.empty) + expand_inductive env ((i, ii), u) | App (f, args) -> (match kind f with | Lambda (n, t, b) -> (* Does not yet delta-reduce *) if Array.length args > 0 then - snd (expand_app env (f, args) Evd.empty) + expand_app env (f, args) else default env trm | _ -> default env trm) | _ -> - default env trm + default env trm (* Expand a product type as far as its conclusion goes *) let expand_product_fully (o : context_object) : proof_cat = @@ -163,7 +163,7 @@ let expand_terminal (c : proof_cat) : proof_cat = else AnonymousBinding in - let exp = expand_term (fun env t -> snd (eval_theorem_bind binding env t Evd.empty)) t in + let _, exp = expand_term (eval_theorem_bind binding) t Evd.empty in snd (substitute_terminal c exp Evd.empty) | _ -> c @@ -303,7 +303,7 @@ let expand_application (c, n, l) : proof_cat * int * (types list) = expand_const_app env (c, u) (f, args) l | _ -> let c_trm = Context (Term (trm, env), fid ()) in - let exp = expand_term (fun env t -> snd (eval_theorem env t Evd.empty)) c_trm in + let _, exp = expand_term eval_theorem c_trm Evd.empty in (exp, 0, l)) | _ -> assert false) (only_arrow c) diff --git a/plugin/src/compilation/expansion.mli b/plugin/src/compilation/expansion.mli index b1eb3fe..205a166 100644 --- a/plugin/src/compilation/expansion.mli +++ b/plugin/src/compilation/expansion.mli @@ -3,6 +3,8 @@ open Environ open Constr open Proofcat +open Evd +open Stateutils (* --- Type definitions --- *) @@ -10,13 +12,6 @@ type 'a expansion_strategy = 'a -> 'a (* --- Contexts --- *) -(* - * Expand a term exactly once - * Default to using the provided function when it cannot be expanded further - * Error if the type context doesn't hold any terms - *) -val expand_term : (env -> types -> proof_cat) -> context_object -> proof_cat - (* * Expand a product type as far as its conclusion goes * Error if the type context doesn't hold any terms From 001be6b3fa54f35f5a4fa629c503e09eed1ddc4c Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 13:29:38 -0700 Subject: [PATCH 108/154] context expansion evar_maps --- plugin/src/compilation/expansion.ml | 21 +++++++++++++-------- plugin/src/compilation/expansion.mli | 9 --------- 2 files changed, 13 insertions(+), 17 deletions(-) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index f46bc96..1fbd17a 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -131,17 +131,22 @@ let expand_term (default : env -> types -> evar_map -> proof_cat state) (o : con default env trm (* Expand a product type as far as its conclusion goes *) -let expand_product_fully (o : context_object) : proof_cat = +let expand_product_fully (o : context_object) = let rec expand_fully env (n, t, b) = match kind b with | Prod (n', t', b') -> - let _, t'' = eval_theorem env t Evd.empty in - let env' = push_rel CRD.(LocalAssum(n, t)) env in - let b'' = expand_fully env' (n', t', b') in - let _, c = substitute_categories t'' b'' Evd.empty in - snd (bind_cat c (initial c, LazyBinding (mkRel 1, env'), terminal t'') Evd.empty) + bind + (eval_theorem env t) + (fun t'' -> + let env' = push_local (n, t) env in + bind + (bind (expand_fully env' (n', t', b')) (substitute_categories t'')) + (fun c -> + let init_o = initial c in + let term_o = terminal t'' in + bind_cat c (init_o, LazyBinding (mkRel 1, env'), term_o))) | _ -> - snd (expand_product env (n, t, b) Evd.empty) + expand_product env (n, t, b) in expand_fully (context_env o) (destProd (fst (dest_context_term o))) (* --- Categories --- *) @@ -186,7 +191,7 @@ let partition_expandable (c : proof_cat) : (arrow list * arrow list) = let expand_inductive_conclusions (ms : arrow list) : proof_cat list = List.map (fun (s, e, d) -> - let dc = expand_product_fully d in + let _, dc = expand_product_fully d Evd.empty in let map_i_to_src m sigma = sigma, if (snd (objects_equal (initial dc) m Evd.empty)) then s else m in let arity = (List.length (morphisms dc)) - 1 in snd diff --git a/plugin/src/compilation/expansion.mli b/plugin/src/compilation/expansion.mli index 205a166..2162c04 100644 --- a/plugin/src/compilation/expansion.mli +++ b/plugin/src/compilation/expansion.mli @@ -10,15 +10,6 @@ open Stateutils type 'a expansion_strategy = 'a -> 'a -(* --- Contexts --- *) - -(* - * Expand a product type as far as its conclusion goes - * Error if the type context doesn't hold any terms - * Error if the type context isn't newly extended with a product type - *) -val expand_product_fully : context_object -> proof_cat - (* --- Categories --- *) (* From daf314b45dc312b6b5ae5d31b201362bc5791f4d Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 13:41:03 -0700 Subject: [PATCH 109/154] more evar_maps in expansion --- .../src/compilation/categories/catzooming.ml | 2 +- plugin/src/compilation/expansion.ml | 44 ++++++++++++------- plugin/src/compilation/expansion.mli | 3 +- 3 files changed, 30 insertions(+), 19 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index 645db7b..d0e9c55 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -143,7 +143,7 @@ let zoom_search f (d : goal_proof_diff) : candidates = zoom_map f give_up - expand_terminal + (fun c -> snd (expand_terminal c Evd.empty)) intro_common (erase_goals d) diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 1fbd17a..44b2c2f 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -42,6 +42,7 @@ let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool sta (* --- Type definitions --- *) type 'a expansion_strategy = 'a -> 'a +type 'a expansion_strategy_todo = 'a -> evar_map -> 'a state (* --- Terms and types --- *) @@ -155,23 +156,26 @@ let expand_product_fully (o : context_object) = * Expand the terminal object of c exactly once * Return c if it cannot be expanded *) -let expand_terminal (c : proof_cat) : proof_cat = +let expand_terminal (c : proof_cat) = let t = terminal c in match t with | Context (Term (trm, env), i) -> let ms = morphisms c in - let _, concls = arrows_with_dest t ms Evd.empty in - let binding = - if non_empty concls then - let (_, ext, _) = List.hd concls in (* arbitrary for now *) - ext - else - AnonymousBinding - in - let _, exp = expand_term (eval_theorem_bind binding) t Evd.empty in - snd (substitute_terminal c exp Evd.empty) + bind + (arrows_with_dest t ms) + (fun concls -> + let binding = + if non_empty concls then + let (_, ext, _) = List.hd concls in (* arbitrary for now *) + ext + else + AnonymousBinding + in + bind + (expand_term (eval_theorem_bind binding) t) + (substitute_terminal c)) | _ -> - c + ret c (* * Utility function for expanding inductive proofs @@ -179,9 +183,15 @@ let expand_terminal (c : proof_cat) : proof_cat = * 1. Morphisms that end in a product type that is not a hypothesis * 2. Morphisms that do not *) -let partition_expandable (c : proof_cat) : (arrow list * arrow list) = - List.partition - (fun m -> snd (map_dest (fun o sigma -> sigma, context_is_product o && snd (is_not_hypothesis c o sigma)) m Evd.empty)) +let partition_expandable (c : proof_cat) = + partition_state + (map_dest + (fun o -> + and_state + (fun o -> ret (context_is_product o)) + (is_not_hypothesis c) + o + o)) (morphisms c) (* @@ -214,7 +224,7 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = *) let expand_inductive_conclusions_fully (c : proof_cat) : proof_cat = let _, c_os = objects c Evd.empty in - let (ms_to_expand, old_ms) = partition_expandable c in + let _, (ms_to_expand, old_ms) = partition_expandable c Evd.empty in let _, old_os = all_objects_except_those_in (conclusions ms_to_expand) c_os Evd.empty in let expanded = expand_inductive_conclusions ms_to_expand in let new_os = flat_map (fun os -> snd (map_objects (fun o sigma -> all_objects_except_those_in c_os o sigma) os Evd.empty)) expanded in @@ -229,7 +239,7 @@ let expand_inductive_params (n : int) (c : proof_cat) : proof_cat = if n' < 0 || (not (context_is_product (terminal c'))) then c' else - expand (n' - 1) (expand_terminal c') + expand (n' - 1) (snd (expand_terminal c' Evd.empty)) in expand n c (* Check if an o is the type of an applied inductive hypothesis in c *) diff --git a/plugin/src/compilation/expansion.mli b/plugin/src/compilation/expansion.mli index 2162c04..29b80c6 100644 --- a/plugin/src/compilation/expansion.mli +++ b/plugin/src/compilation/expansion.mli @@ -9,6 +9,7 @@ open Stateutils (* --- Type definitions --- *) type 'a expansion_strategy = 'a -> 'a +type 'a expansion_strategy_todo = 'a -> evar_map -> 'a state (* --- Categories --- *) @@ -16,7 +17,7 @@ type 'a expansion_strategy = 'a -> 'a * Expand the terminal object of a proof category exactly once * Return the original category if it cannot be exapnded *) -val expand_terminal : proof_cat expansion_strategy +val expand_terminal : proof_cat expansion_strategy_todo (* * Expand all parameters of an inductive proof From 01690ba3cf8fb31773431f23ccaef02da8cb3ea7 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 14:03:12 -0700 Subject: [PATCH 110/154] update lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index ff6dba0..5373e27 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit ff6dba062de52ce1dbe75918ec6d5c82313a2945 +Subproject commit 5373e277ccb4b396776680cd76d7628540132785 From d67f813be6c9710e4a7390d2204da37fb5a1bad6 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 14:05:02 -0700 Subject: [PATCH 111/154] update lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 5373e27..63d42f8 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 5373e277ccb4b396776680cd76d7628540132785 +Subproject commit 63d42f80f70e761918dbdcdba1c9704b0ca7962d From 181c184e83f6066ae92f9d1bc8f16f21d605dc25 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 14:13:46 -0700 Subject: [PATCH 112/154] update lib --- plugin/src/coq-plugin-lib | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 63d42f8..f2b83d2 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 63d42f80f70e761918dbdcdba1c9704b0ca7962d +Subproject commit f2b83d2d354579f088a4e1b0cf1bd0e228991a22 From 041f44563bac4e5208a63604dd27c486c317efb0 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 14:51:33 -0700 Subject: [PATCH 113/154] finish expansion evar-maps --- .../src/compilation/categories/catzooming.ml | 5 +- .../src/compilation/categories/catzooming.mli | 6 +- plugin/src/compilation/expansion.ml | 134 +++++++++++------- plugin/src/compilation/expansion.mli | 12 +- plugin/src/compilation/proofdiff.ml | 4 +- .../differencing/inddifferencers.ml | 2 +- .../src/representation/categories/proofcat.ml | 6 +- .../representation/categories/proofcat.mli | 4 +- .../categories/proofcatterms.ml | 24 ++-- 9 files changed, 111 insertions(+), 86 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index d0e9c55..7e144ac 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -13,9 +13,10 @@ open Debruijn type search_function = proof_cat_diff -> candidates type 'a intro_strategy = 'a proof_diff -> 'a proof_diff option +type 'a expansion_strategy_old = 'a -> 'a (* TODO remove me *) type 'a zoomer = - 'a expansion_strategy -> + 'a expansion_strategy_old -> 'a intro_strategy -> 'a proof_diff -> 'a proof_diff option @@ -136,7 +137,7 @@ let zoom_map f a expander introducer d = f (Option.get zoomed) (* Zoom over two inductive proofs that induct over the same hypothesis *) -let zoom_same_hypos = zoom expand_application (fun d -> Some d) +let zoom_same_hypos = zoom (fun c -> snd (expand_application c Evd.empty)) (fun d -> Some d) (* Default zoom for recursive search *) let zoom_search f (d : goal_proof_diff) : candidates = diff --git a/plugin/src/compilation/categories/catzooming.mli b/plugin/src/compilation/categories/catzooming.mli index 374facd..ab8815e 100644 --- a/plugin/src/compilation/categories/catzooming.mli +++ b/plugin/src/compilation/categories/catzooming.mli @@ -37,8 +37,10 @@ type 'a intro_strategy = 'a proof_diff -> 'a proof_diff option * since that is not possible. *) +type 'a expansion_strategy_old = 'a -> 'a (* TODO remove me *) + type 'a zoomer = - 'a expansion_strategy -> + 'a expansion_strategy_old -> 'a intro_strategy -> 'a proof_diff -> 'a proof_diff option @@ -94,7 +96,7 @@ val zoom : 'a zoomer val zoom_map : ('a proof_diff -> 'b) -> 'b -> - 'a expansion_strategy -> + 'a expansion_strategy_old -> 'a intro_strategy -> 'a proof_diff -> 'b diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index 44b2c2f..b7a2905 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -41,8 +41,7 @@ let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool sta (* --- Type definitions --- *) -type 'a expansion_strategy = 'a -> 'a -type 'a expansion_strategy_todo = 'a -> evar_map -> 'a state +type 'a expansion_strategy = 'a -> evar_map -> 'a state (* --- Terms and types --- *) @@ -198,18 +197,20 @@ let partition_expandable (c : proof_cat) = * Utility function for expanding inductive proofs * Expand conclusions of different cases of an inductive proof that are dependent *) -let expand_inductive_conclusions (ms : arrow list) : proof_cat list = - List.map +let expand_inductive_conclusions (ms : arrow list) = + map_state (fun (s, e, d) -> - let _, dc = expand_product_fully d Evd.empty in - let map_i_to_src m sigma = sigma, if (snd (objects_equal (initial dc) m Evd.empty)) then s else m in - let arity = (List.length (morphisms dc)) - 1 in - snd - (bind_apply_function - (shift_ext_by arity (substitute_ext_env (context_env (terminal dc)) e)) - arity - (snd (apply_functor map_i_to_src (map_source_arrow map_i_to_src) dc Evd.empty)) - Evd.empty)) + bind + (expand_product_fully d) + (fun dc -> + let map_i_to_src = + branch_state (objects_equal (initial dc)) (fun _ -> ret s) ret + in + let arity = (List.length (morphisms dc)) - 1 in + let env = substitute_ext_env (context_env (terminal dc)) e in + bind + (apply_functor map_i_to_src (map_source_arrow map_i_to_src) dc) + (bind_apply_function (shift_ext_by arity env) arity))) ms (* @@ -222,34 +223,41 @@ let expand_inductive_conclusions (ms : arrow list) : proof_cat list = * especially relevant when we add support for mutually * inductive types. *) -let expand_inductive_conclusions_fully (c : proof_cat) : proof_cat = - let _, c_os = objects c Evd.empty in - let _, (ms_to_expand, old_ms) = partition_expandable c Evd.empty in - let _, old_os = all_objects_except_those_in (conclusions ms_to_expand) c_os Evd.empty in - let expanded = expand_inductive_conclusions ms_to_expand in - let new_os = flat_map (fun os -> snd (map_objects (fun o sigma -> all_objects_except_those_in c_os o sigma) os Evd.empty)) expanded in +let expand_inductive_conclusions_fully (c : proof_cat) sigma = + let sigma, c_os = objects c sigma in + let sigma, (ms_to_expand, old_ms) = partition_expandable c sigma in + let sigma, old_os = all_objects_except_those_in (conclusions ms_to_expand) c_os sigma in + let sigma, expanded = expand_inductive_conclusions ms_to_expand sigma in + let sigma, new_os = flat_map_state (map_objects (all_objects_except_those_in c_os)) expanded sigma in let new_ms = flat_map morphisms expanded in let os = List.append old_os new_os in let ms = List.append old_ms new_ms in - snd (make_category os ms (initial_opt c) None Evd.empty) + make_category os ms (initial_opt c) None sigma + (* For an inductive proof, expand n inductive parameters and the principle P *) -let expand_inductive_params (n : int) (c : proof_cat) : proof_cat = +let expand_inductive_params (n : int) (c : proof_cat) = let rec expand n' c' = if n' < 0 || (not (context_is_product (terminal c'))) then - c' + ret c' else - expand (n' - 1) (snd (expand_terminal c' Evd.empty)) + bind (expand_terminal c') (expand (n' - 1)) in expand n c (* Check if an o is the type of an applied inductive hypothesis in c *) -let applies_ih (env : env) (evd : evar_map) (p : types) (c : proof_cat) (o : context_object) : bool = +let applies_ih (env : env) (p : types) (c : proof_cat) (o : context_object) = if context_is_app o then let (f, _) = context_as_app o in - let f = unshift_by (snd (shortest_path_length c o Evd.empty)) f in - snd (is_hypothesis c o Evd.empty) && snd (has_type env evd p f) + bind + (shortest_path_length c o) + (fun n -> + and_state + (is_hypothesis c) + (fun f sigma -> has_type env sigma p f) + o + (unshift_by n f)) else - false + ret false (* * Bind the inductive hypotheses in an expanded constructor with parameters @@ -258,33 +266,43 @@ let applies_ih (env : env) (evd : evar_map) (p : types) (c : proof_cat) (o : con * This also may fail if the IH is applied to something when we expand * So we should test for that case *) -let bind_ihs (c : proof_cat) : proof_cat = - let env_with_p = context_env (snd (context_at_index c 1 Evd.empty)) in - let (_, _, p) = CRD.to_tuple @@ lookup_rel 1 env_with_p in - let env = pop_rel_context 1 env_with_p in - snd - (apply_functor - (fun o -> ret o) - (fun m -> - if snd (map_dest (fun o sigma -> sigma, applies_ih env sigma p c o) m Evd.empty) then - ret (map_ext_arrow (fun _ -> fresh_ih ()) m) - else - ret m) - c - Evd.empty) +let bind_ihs (c : proof_cat) = + bind + (context_at_index c 1) + (fun context -> + let env_with_p = context_env context in + let (_, _, p) = CRD.to_tuple @@ lookup_rel 1 env_with_p in + let env = pop_rel_context 1 env_with_p in + apply_functor + (fun o -> ret o) + (branch_state + (map_dest (applies_ih env p c)) + (map_ext_arrow (fun _ -> ret (fresh_ih ()))) + ret) + c) (* * Expand an inductive constructor * That is, expand its conclusion fully if it is dependent * Then mark the edges that are inductive hypotheses *) -let expand_constr (c : proof_cat) : proof_cat = - let c_exp = bind_ihs (expand_inductive_conclusions_fully c) in - let ms = morphisms c_exp in - let assums = hypotheses ms in - let concls = conclusions ms in - let tr = List.hd (snd (all_objects_except_those_in assums concls Evd.empty)) in (*arbitrary*) - snd (make_category (snd (objects c_exp Evd.empty)) ms (initial_opt c_exp) (Some tr) Evd.empty) +let expand_constr (c : proof_cat) = + bind + (expand_inductive_conclusions_fully c) + (fun c -> + bind + (bind_ihs c) + (fun c_exp -> + let ms = morphisms c_exp in + let assums = hypotheses ms in + let concls = conclusions ms in + bind + (all_objects_except_those_in assums concls) + (fun trs -> + let tr = List.hd trs in + bind + (objects c_exp) + (fun os -> make_category os ms (initial_opt c_exp) (Some tr))))) (* * Expand the application of a constant function @@ -294,11 +312,16 @@ let expand_const_app env (c, u) (f, args) default = match inductive_of_elim env (c, u) with | Some mutind -> let mutind_body = lookup_mind mutind env in - let _, f_c = eval_proof env f Evd.empty in - let f_exp = expand_inductive_params mutind_body.mind_nparams f_c in - snd (eval_induction mutind_body f_exp args Evd.empty) + bind + (bind + (eval_proof env f) + (expand_inductive_params mutind_body.mind_nparams)) + (fun f_exp -> + eval_induction mutind_body f_exp args) | None -> - (snd (eval_proof env (mkApp (f, args)) Evd.empty), 0, default) + bind + (eval_proof env (mkApp (f, args))) + (fun exp -> ret (exp, 0, default)) (* * Expand an application arrow @@ -307,7 +330,7 @@ let expand_const_app env (c, u) (f, args) default = * Otherwise, there is an error * Like the above, this will not work yet when induction is later in the proof *) -let expand_application (c, n, l) : proof_cat * int * (types list) = +let expand_application (c, n, l) = map_ext (fun e -> match e with @@ -318,7 +341,8 @@ let expand_application (c, n, l) : proof_cat * int * (types list) = expand_const_app env (c, u) (f, args) l | _ -> let c_trm = Context (Term (trm, env), fid ()) in - let _, exp = expand_term eval_theorem c_trm Evd.empty in - (exp, 0, l)) + bind + (expand_term eval_theorem c_trm) + (fun exp -> ret (exp, 0, l))) | _ -> assert false) (only_arrow c) diff --git a/plugin/src/compilation/expansion.mli b/plugin/src/compilation/expansion.mli index 29b80c6..27a7711 100644 --- a/plugin/src/compilation/expansion.mli +++ b/plugin/src/compilation/expansion.mli @@ -8,8 +8,7 @@ open Stateutils (* --- Type definitions --- *) -type 'a expansion_strategy = 'a -> 'a -type 'a expansion_strategy_todo = 'a -> evar_map -> 'a state +type 'a expansion_strategy = 'a -> evar_map -> 'a state (* --- Categories --- *) @@ -17,14 +16,7 @@ type 'a expansion_strategy_todo = 'a -> evar_map -> 'a state * Expand the terminal object of a proof category exactly once * Return the original category if it cannot be exapnded *) -val expand_terminal : proof_cat expansion_strategy_todo - -(* - * Expand all parameters of an inductive proof - * Also expand out the node with the induction principle - * Provide the number of parameters to expand - *) -val expand_inductive_params : int -> proof_cat expansion_strategy +val expand_terminal : proof_cat expansion_strategy (* * Expand an inductive constructor diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 45f4d31..12fd955 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -183,8 +183,8 @@ let dest_cases (d : case_diff) : proof_cat_diff list = (* Expand constructors in a proof_cat_diff *) let expand_constrs (d : proof_cat_diff) : proof_cat_diff = - let o = expand_constr (old_proof d) in - let n = expand_constr (new_proof d) in + let o = snd (expand_constr (old_proof d) Evd.empty) in + let n = snd (expand_constr (new_proof d) Evd.empty) in difference o n (assumptions d) (* --- Construction and destruction --- *) diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 006181f..4ebfe12 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -191,7 +191,7 @@ let diff_inductive diff d_old opts evd (d : (proof_cat * int) proof_diff) : cand else zoom_map (fun d -> - let sort c = base_cases_first (List.map expand_constr (snd (split c Evd.empty))) in + let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in let d_sorted = map_diffs sort id d in let ds = dest_cases d_sorted in List.map (unshift_by nparams_o) (diff_ind_cases opts evd diff d_old ds)) diff --git a/plugin/src/representation/categories/proofcat.ml b/plugin/src/representation/categories/proofcat.ml index 7fe447b..3958886 100644 --- a/plugin/src/representation/categories/proofcat.ml +++ b/plugin/src/representation/categories/proofcat.ml @@ -220,7 +220,7 @@ let map_dest (f : context_object -> evar_map -> 'a state) (m : arrow) = (* * Map a function on the extension of an arrow *) -let map_ext (f : extension -> 'a) (m : arrow) : 'a = +let map_ext (f : extension -> evar_map -> 'a state) (m : arrow) = let (_, e, _) = m in f e @@ -241,9 +241,9 @@ let map_dest_arrow (f : context_object -> evar_map -> context_object state) (m : (* * Map a function on the extension of an arrow and return a new arrow *) -let map_ext_arrow (f : extension -> extension) (m : arrow) : arrow = +let map_ext_arrow (f : extension -> evar_map -> extension state) (m : arrow) = let (src, e, dst) = m in - (src, f e, dst) + bind (f e) (fun e' -> ret (src, e', dst)) (* * True iff an arrow m maps from o diff --git a/plugin/src/representation/categories/proofcat.mli b/plugin/src/representation/categories/proofcat.mli index 911e17b..b2817f8 100644 --- a/plugin/src/representation/categories/proofcat.mli +++ b/plugin/src/representation/categories/proofcat.mli @@ -119,7 +119,7 @@ val map_dest : (context_object -> evar_map -> 'a state) -> arrow -> evar_map -> (* * Map a function on the extension of an arrow *) -val map_ext : (extension -> 'a) -> arrow -> 'a +val map_ext : (extension -> evar_map -> 'a state) -> arrow -> evar_map -> 'a state (* * Map a function on the destination of an arrow and return a new arrow @@ -134,7 +134,7 @@ val map_dest_arrow : (context_object -> evar_map -> context_object state) -> arr (* * Map a function on the extension of an arrow and return a new arrow *) -val map_ext_arrow : (extension -> extension) -> arrow -> arrow +val map_ext_arrow : (extension -> evar_map -> extension state) -> arrow -> evar_map -> arrow state (* * True iff an arrow maps from the provided object diff --git a/plugin/src/representation/categories/proofcatterms.ml b/plugin/src/representation/categories/proofcatterms.ml index e0e41e4..16fb4e2 100644 --- a/plugin/src/representation/categories/proofcatterms.ml +++ b/plugin/src/representation/categories/proofcatterms.ml @@ -162,9 +162,11 @@ let prop (c : proof_cat) (npms : int) = * Get the only extension in a proof category as a term * Fail if there are no extensions * Fail if there are multiple extensions + * + * Evd.empty is OK here since evar_maps aren't used in ext_term *) let only_extension_as_term (c : proof_cat) : types = - map_ext ext_term (only_arrow c) + snd (map_ext (fun t -> ret (ext_term t)) (only_arrow c) Evd.empty) (* * Given a proof category with several paths, @@ -579,7 +581,7 @@ let bind_inductive_arg (arg : types) (c : proof_cat) = ret (branch_state (maps_to t) - (fun m -> ret (map_ext_arrow (fun _ -> bound) m)) + (fun m -> ret (snd (map_ext_arrow (fun _ -> ret bound) m Evd.empty))) ret) c @@ -602,9 +604,11 @@ let bind_property_arrow (po : types option) (m : arrow) = (map_dest (fun o -> ret (context_env o)) m) (fun env -> ret - (map_ext_arrow - (fun e -> Option.default e (Option.map (ext_of_term env) po)) - m)) + (snd + (map_ext_arrow + (fun e -> ret (Option.default e (Option.map (ext_of_term env) po))) + m + Evd.empty))) (* * Auxiliary function for binding properties and parameters @@ -619,9 +623,11 @@ let bind_param_arrows (ps : types list) (ms : arrow list) = ret (List.mapi (fun i m -> - map_ext_arrow - (fun e -> if i < Array.length pes then pes.(i) else e) - m) + snd + (map_ext_arrow + (fun e -> ret (if i < Array.length pes then pes.(i) else e)) + m + Evd.empty)) ms)) (* @@ -706,7 +712,7 @@ let sub_arr_property_params pi pb subs ds m = * Substitute a property and parameters into an a category c. *) let sub_property_params npms pms pb c = - let pms_es = List.map (map_ext ext_term) pms in + let pms_es = List.map (fun pm -> snd (map_ext (fun t -> ret (ext_term t)) pm Evd.empty)) pms in let pms_shift = List.mapi (fun j t -> shift_by_unconditional (- (npms - j)) t) pms_es in let pms_shift_rev = List.rev pms_shift in let pms_subs = build_n_substitutions npms pms_shift_rev no_substitutions in From b2626bbcae30faff2154a7b604440e222bb68a0d Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 18:01:10 -0700 Subject: [PATCH 114/154] proofdiff evar_maps --- plugin/src/compilation/proofdiff.ml | 95 ++++++++++--------- plugin/src/compilation/proofdiff.mli | 23 +++-- plugin/src/configuration/searchopts.ml | 2 +- .../components/differencing/differencing.ml | 8 +- .../differencing/higherdifferencers.ml | 2 +- .../differencing/inddifferencers.ml | 2 +- 6 files changed, 70 insertions(+), 62 deletions(-) diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index 12fd955..afd7d7f 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -14,11 +14,7 @@ open Utilities open Merging open Indutils open Convertibility - -(* - * Note: Evar discipline here is not good yet, but will change - * when we refactor later. - *) +open Stateutils (* --- Types --- *) @@ -146,17 +142,21 @@ let proof_to_term (d : goal_proof_diff) : goal_term_diff = * Retain the same goals and assumptions, * but update the term in a goal proof diff *) -let eval_with_term f g trm (d : goal_proof_diff) : goal_proof_diff = +let eval_with_term f g trm (d : goal_proof_diff) = let (goal, _) = f d in let env = context_env goal in - g (goal, snd (eval_proof env trm Evd.empty)) d + bind + (eval_proof env trm) + (fun p -> g (goal, p) d) -let eval_with_old_term = eval_with_term old_proof with_old_proof +let eval_with_old_term = + eval_with_term old_proof (fun o p -> ret (with_old_proof o p)) -let eval_with_new_term = eval_with_term new_proof with_new_proof +let eval_with_new_term = + eval_with_term new_proof (fun n p -> ret (with_new_proof n p)) let eval_with_terms o n d = - eval_with_old_term o (eval_with_new_term n d) + bind (eval_with_new_term n d) (eval_with_old_term o) (* Destruct the contexts in a diff and return a new diff *) let dest_goals (d : 'a goal_diff) = @@ -182,10 +182,13 @@ let dest_cases (d : case_diff) : proof_cat_diff list = List.map2 (fun o n -> difference o n assums) os ns (* Expand constructors in a proof_cat_diff *) -let expand_constrs (d : proof_cat_diff) : proof_cat_diff = - let o = snd (expand_constr (old_proof d) Evd.empty) in - let n = snd (expand_constr (new_proof d) Evd.empty) in - difference o n (assumptions d) +let expand_constrs (d : proof_cat_diff) = + bind + (expand_constr (old_proof d)) + (fun o -> + bind + (expand_constr (new_proof d)) + (fun n -> ret (difference o n (assumptions d)))) (* --- Construction and destruction --- *) @@ -226,13 +229,6 @@ let merge_diff_closures (d : goal_type_term_diff) (trms : types list) = (old_goal_env, List.append [old_goal_type; old_term] trms) assums -(* Get the reduced proof terms for a proof diff *) -let reduced_proof_terms (r : reducer) (d : goal_proof_diff) : env * types * types = - let (env, ns, os) = merge_diff_closures (dest_goals (proof_to_term d)) [] in - let [new_goal_type; new_term] = ns in - let [old_goal_type; old_term] = os in - (env, snd (r env Evd.empty old_term), snd (r env Evd.empty new_term)) - (* Get the goal types for a lift goal diff *) let goal_types (d : lift_goal_diff) : types * types = let d_type_env = dest_lift_goals d in @@ -243,42 +239,50 @@ let goal_types (d : lift_goal_diff) : types * types = (* --- Reduction and Simplification --- *) (* Reduce the terms inside of a goal_proof_diff *) -let reduce_diff (r : reducer) (d : goal_proof_diff) : goal_proof_diff = +let reduce_diff (r : reducer) (d : goal_proof_diff) = let (o, n) = proof_terms d in let (goal_o, _) = old_proof d in let (goal_n, _) = new_proof d in let env_o = context_env goal_o in let env_n = context_env goal_n in - eval_with_terms (snd (r env_o Evd.empty o)) (snd (r env_n Evd.empty n)) d + bind + (fun sigma -> r env_o sigma o) + (fun o -> + bind + (fun sigma -> r env_n sigma n) + (fun n -> eval_with_terms o n d)) (* Given a difference in proofs, trim down any casts and get the terms *) -let rec reduce_casts (d : goal_proof_diff) : goal_proof_diff = +let rec reduce_casts (d : goal_proof_diff) = match map_tuple kind (proof_terms d) with | (Cast (t, _, _), _) -> - reduce_casts (eval_with_old_term t d) + bind (eval_with_old_term t d) reduce_casts | (_, Cast (t, _, _)) -> - reduce_casts (eval_with_new_term t d) + bind (eval_with_new_term t d) reduce_casts | _ -> - d + ret d (* * Given a difference in proofs, substitute the head let ins * Fail silently *) -let reduce_letin (d : goal_proof_diff) : goal_proof_diff = +let reduce_letin (d : goal_proof_diff) = let (o, n) = proof_terms d in try if isLetIn o || isLetIn n then let d_dest = dest_goals d in let ((_, old_env), _) = old_proof d_dest in let ((_, new_env), _) = new_proof d_dest in - let o' = snd (reduce_whd_if_let_in old_env Evd.empty o) in - let n' = snd (reduce_whd_if_let_in new_env Evd.empty n) in - eval_with_terms o' n' d + bind + (fun sigma -> reduce_whd_if_let_in old_env sigma o) + (fun o' -> + bind + (fun sigma -> reduce_whd_if_let_in new_env sigma n) + (fun n' -> eval_with_terms o' n' d)) else - d + ret d with _ -> - d + ret d (* Given a term, trim off the IH, assuming it's an application *) let trim_ih (trm : types) : types = @@ -288,7 +292,7 @@ let trim_ih (trm : types) : types = mkApp (f, args_trim) (* Given a diff, trim off the IHs, assuming the terms are applications *) -let reduce_trim_ihs (d : goal_proof_diff) : goal_proof_diff = +let reduce_trim_ihs (d : goal_proof_diff) = let (old_term, new_term) = map_tuple trim_ih (proof_terms d) in eval_with_terms old_term new_term d @@ -299,18 +303,23 @@ let reduce_trim_ihs (d : goal_proof_diff) : goal_proof_diff = * Shift by the number of morphisms in the case, * assuming they are equal when they are convertible *) -let update_case_assums (d_ms : (arrow list) proof_diff) : equal_assumptions = - List.fold_left2 - (fun assums dst_o dst_n -> +let update_case_assums (d_ms : (arrow list) proof_diff) = + fold_left_state + (fun assums (dst_o, dst_n) -> let d = difference dst_o dst_n assums in let (env, d_goal, _) = merge_lift_diff_envs d [] in - if snd (convertible env Evd.empty (old_proof d_goal) (new_proof d_goal)) then - assume_local_equal assums - else - shift_assumptions assums) + branch_state + (fun d_goal sigma -> + convertible env sigma (old_proof d_goal) (new_proof d_goal)) + (fun _ -> ret (assume_local_equal assums)) + (fun _ -> ret (shift_assumptions assums)) + d_goal) (assumptions d_ms) - (conclusions (all_but_last (old_proof d_ms))) - (conclusions (all_but_last (new_proof d_ms))) + (List.fold_right2 + (fun dst_o dst_n combined -> (dst_o, dst_n) :: combined) + (conclusions (all_but_last (old_proof d_ms))) + (conclusions (all_but_last (new_proof d_ms))) + []) (* --- Questions about differences between proofs --- *) diff --git a/plugin/src/compilation/proofdiff.mli b/plugin/src/compilation/proofdiff.mli index 5900e27..7917ac8 100644 --- a/plugin/src/compilation/proofdiff.mli +++ b/plugin/src/compilation/proofdiff.mli @@ -6,6 +6,8 @@ open Proofcat open Assumptions open Reducers open Merging +open Stateutils +open Evd (* --- Types --- *) @@ -67,9 +69,6 @@ val diff_proofs : 'a goal_diff -> 'a * 'a (* Get the proof terms for a proof diff *) val proof_terms : goal_proof_diff -> (types * types) -(* Get the reduced proof terms for a proof diff *) -val reduced_proof_terms : reducer -> goal_proof_diff -> env * types * types - (* Get the goal types for a lift goal diff *) val goal_types : lift_goal_diff -> (types * types) @@ -125,19 +124,19 @@ val proof_to_term : goal_proof_diff -> goal_term_diff * Retain the same goals and assumptions, but update the old proof * with a term in a goal proof diff *) -val eval_with_old_term : types -> goal_proof_diff -> goal_proof_diff +val eval_with_old_term : types -> goal_proof_diff -> evar_map -> goal_proof_diff state (* * Retain the same goals and assumptions, but update the new proof * with a term in a goal proof diff *) -val eval_with_new_term : types -> goal_proof_diff -> goal_proof_diff +val eval_with_new_term : types -> goal_proof_diff -> evar_map -> goal_proof_diff state (* * Retain the same goals and assumptions, but update the old and new * terms with the terms in a goal proof diff *) -val eval_with_terms : types -> types -> goal_proof_diff -> goal_proof_diff +val eval_with_terms : types -> types -> goal_proof_diff -> evar_map -> goal_proof_diff state (* * Destruct the contexts in a goal_diff and return a new diff @@ -157,7 +156,7 @@ val dest_cases : case_diff -> proof_cat_diff list (* * Expand constructors in a proof_cat_diff *) -val expand_constrs : proof_cat_diff -> proof_cat_diff +val expand_constrs : proof_cat_diff -> evar_map -> proof_cat_diff state (* --- Merging environments for diffs --- *) @@ -180,19 +179,19 @@ val merge_diff_closures : (* --- Reduction and Simplification --- *) (* Reduce the terms inside of a goal_proof_diff *) -val reduce_diff : reducer -> goal_proof_diff -> goal_proof_diff +val reduce_diff : reducer -> goal_proof_diff -> evar_map -> goal_proof_diff state (* Given a difference in proofs, trim down any casts and get the terms *) -val reduce_casts : goal_proof_diff -> goal_proof_diff +val reduce_casts : goal_proof_diff -> evar_map -> goal_proof_diff state (* * Given a differrence in proofs, weak head reduce any let-ins * If this fails because of a substituted assumption, then fail silently *) -val reduce_letin : goal_proof_diff -> goal_proof_diff +val reduce_letin : goal_proof_diff -> evar_map -> goal_proof_diff state (* Given a difference in proofs, trim applications of the IH *) -val reduce_trim_ihs : goal_proof_diff -> goal_proof_diff +val reduce_trim_ihs : goal_proof_diff -> evar_map -> goal_proof_diff state (* --- Assumptions --- *) @@ -200,7 +199,7 @@ val reduce_trim_ihs : goal_proof_diff -> goal_proof_diff * Update the assumptions in the difference between a case of an inductive proof * Assume terms are equal when they are convertible, and offset accordingly *) -val update_case_assums : (arrow list) proof_diff -> equal_assumptions +val update_case_assums : (arrow list) proof_diff -> evar_map -> equal_assumptions state (* --- Questions about a difference between proofs --- *) diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index 268f903..d88d615 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -275,7 +275,7 @@ let is_ind opts = opts.is_ind (* Keep the same assumptions, but update the goals and terms for a diff *) let update_terms_goals opts t_o t_n d = let update = update_search_goals opts d in - update (erase_goals (eval_with_terms t_o t_n d)) + update (erase_goals (snd (eval_with_terms t_o t_n d Evd.empty))) (* Convert search to a search_function for zooming *) let to_search_function search opts d : search_function = diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index fa8395c..b96531f 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -83,7 +83,7 @@ let debug_search (d : goal_proof_diff) : unit = * recursively. (Support for this is preliminary.) *) let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidates = - let d = reduce_letin (reduce_casts d) in + let d = snd (reduce_letin (snd (reduce_casts d Evd.empty)) Evd.empty) in if no_diff evd opts d then (*1*) identity_candidates d else if induct_over_same_h (same_h opts) d then @@ -93,7 +93,7 @@ let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidate d else if applies_ih opts d then let diff opts = diff opts evd in - (*3*) diff_app evd diff diff opts (reduce_trim_ihs d) + (*3*) diff_app evd diff diff opts (snd (reduce_trim_ihs d Evd.empty)) else let diff opts = diff opts evd in match map_tuple kind (proof_terms d) with @@ -101,7 +101,7 @@ let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidate let change = get_change opts in let ind = is_ind opts in let opts_hypos = if is_identity change then set_change opts Conclusion else opts in - if no_diff evd opts_hypos (eval_with_terms t_o t_n d) then + if no_diff evd opts_hypos (snd (eval_with_terms t_o t_n d Evd.empty)) then (*4*) zoom_wrap_lambda (to_search_function diff opts d) n_o t_o d else if ind || not (is_conclusion change || is_identity change) then (*5*) zoom_unshift (to_search_function diff opts d) d @@ -123,6 +123,6 @@ let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidate let get_differencer (opts : options) (evd : evar_map) = let should_reduce = is_inductive_type (get_change opts) in if should_reduce then - (fun d -> diff opts evd (reduce_diff reduce_term d)) + (fun d -> diff opts evd (snd (reduce_diff reduce_term d Evd.empty))) else diff opts evd diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index b7be042..f6c52a9 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -30,7 +30,7 @@ let rec try_chain_diffs diffs d = *) let diff_reduced diff d = let (o, n) = proof_terms d in - let d_red = reduce_diff reduce_term d in + let d_red = snd (reduce_diff reduce_term d Evd.empty) in let (o_red, n_red) = proof_terms d_red in if not ((equal o o_red) && (equal n n_red)) then diff d_red diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 4ebfe12..efa7fa9 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -87,7 +87,7 @@ let diff_sort_ind_case opts evd sort diff d_old (d : proof_cat_diff) : candidate d_old (map_diffs (fun (o, ms) -> (terminal o, ms)) - (fun _ -> (update_case_assums d_ms)) + (fun _ -> snd (update_case_assums d_ms Evd.empty)) (add_to_diff d (sort o ms_o) (sort n ms_n))) in if is_hypothesis (get_change opts) then From f2f832c297c6b973afdb4dbe865eae55de7dad55 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 18:56:15 -0700 Subject: [PATCH 115/154] evar_maps in zooming --- .../src/compilation/categories/catzooming.ml | 122 ++++++++++-------- .../src/compilation/categories/catzooming.mli | 26 ++-- .../differencing/appdifferencers.ml | 2 +- .../components/differencing/differencing.ml | 4 +- .../differencing/inddifferencers.ml | 23 ++-- 5 files changed, 101 insertions(+), 76 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index 7e144ac..71f0d78 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -8,54 +8,59 @@ open Assumptions open Candidates open Constr open Debruijn +open Evd (* --- Zooming --- *) type search_function = proof_cat_diff -> candidates -type 'a intro_strategy = 'a proof_diff -> 'a proof_diff option -type 'a expansion_strategy_old = 'a -> 'a (* TODO remove me *) +type 'a intro_strategy = 'a proof_diff -> evar_map -> ('a proof_diff option) state type 'a zoomer = - 'a expansion_strategy_old -> + 'a expansion_strategy -> 'a intro_strategy -> 'a proof_diff -> - 'a proof_diff option + evar_map -> + ('a proof_diff option) state (* --- Introduction strategies --- *) (* Remove the initial object of c *) -let remove_initial (c : proof_cat) : proof_cat = +let remove_initial (c : proof_cat) = let i = initial c in let ms = morphisms c in - let _, os' = all_objects_except i (snd (objects c Evd.empty)) Evd.empty in - let (ms', ims) = List.partition (fun m -> snd (map_source (fun o sigma -> objects_not_equal i o sigma) m Evd.empty)) ms in - let (_, _, i') = List.hd ims in - snd (make_category os' ms' (Some i') (terminal_opt c) Evd.empty) + bind + (bind (objects c) (all_objects_except i)) + (fun os' -> + bind + (partition_state (map_source (objects_not_equal i)) ms) + (fun (ms', ims) -> + let (_, _, i') = List.hd ims in + make_category os' ms' (Some i') (terminal_opt c))) (* Remove the first n contexts *) -let rec remove_first_n (n : int) (c : proof_cat) : proof_cat = +let rec remove_first_n (n : int) (c : proof_cat) = if n = 0 then - c + ret c else - remove_first_n (n - 1) (remove_initial c) + bind (remove_initial c) (remove_first_n (n - 1)) (* * Introduce n common elements of c1 and c2 if possible * Remove those elements from the premise of c1 and c2 * Add them to assums *) -let intro_common_n n (d : proof_cat_diff) : proof_cat_diff option = +let intro_common_n n (d : proof_cat_diff) sigma = let c1 = old_proof d in let c2 = new_proof d in let assums = assumptions d in if (List.length (morphisms c1) <= n) || (List.length (morphisms c2) <= n) then - None + sigma, None else - Some - (with_old_proof - (remove_first_n n c1) - (with_new_proof - (remove_first_n n c2) + let sigma, c1' = remove_first_n n c1 sigma in + let sigma, c2' = remove_first_n n c2 sigma in + sigma, Some + (with_old_proof c1' + (with_new_proof c2' (with_assumptions (assume_local_n_equal n assums) d))) (* @@ -70,18 +75,18 @@ let intro_common = intro_common_n 1 * Remove those elements from the premise of c1 and c2 * Shift the assumptions *) -let intro_n n (d : proof_cat_diff) : proof_cat_diff option = +let intro_n n (d : proof_cat_diff) sigma = let c1 = old_proof d in let c2 = new_proof d in let assums = assumptions d in if (List.length (morphisms c1) <= n) || (List.length (morphisms c2) <= n) then - None + sigma, None else - Some - (with_old_proof - (remove_first_n n c1) - (with_new_proof - (remove_first_n n c2) + let sigma, c1' = remove_first_n n c1 sigma in + let sigma, c2' = remove_first_n n c2 sigma in + sigma, Some + (with_old_proof c1' + (with_new_proof c2' (with_assumptions (shift_assumptions_by n assums) d))) (* @@ -98,18 +103,26 @@ let intro = intro_n 1 * otherwise it will fail. *) let intro_params nparams d = - intro_common - (Option.get - (List.fold_right2 - (fun (_, e1, _) (_, e2, _) d_opt -> - let d = Option.get d_opt in - if snd (extensions_equal_assums (assumptions d) e1 e2 Evd.empty) then - intro_common d - else - intro d) - (snd (params (old_proof d) nparams Evd.empty)) - (snd (params (new_proof d) nparams Evd.empty)) - (Some d))) + bind + (bind + (bind (params (old_proof d) nparams) (fun l -> ret (List.rev l))) + (fun pms_o -> + bind + (bind (params (new_proof d) nparams) (fun l -> ret (List.rev l))) + (fun pms_n -> + fold_left2_state + (fun d_opt (_, e1, _) (_, e2, _) -> + let d = Option.get d_opt in + branch_state + (fun d -> extensions_equal_assums (assumptions d) e1 e2) + intro_common + intro + d) + (Some d) + pms_o + pms_n))) + (fun o -> intro_common (Option.get o)) + (* --- Zoomers and using zoomers --- *) @@ -117,8 +130,13 @@ let intro_params nparams d = let zoom expander (introducer : 'a intro_strategy) (d : 'a proof_diff) = let a1 = old_proof d in let a2 = new_proof d in - let d = with_old_proof (expander a1) (with_new_proof (expander a2) d) in - introducer d + bind + (expander a1) + (fun o -> + bind + (expander a2) + (fun n -> + introducer (with_old_proof o (with_new_proof n d)))) (* * Zoom @@ -130,38 +148,40 @@ let zoom expander (introducer : 'a intro_strategy) (d : 'a proof_diff) = * help with performance given that it is mutual recursion. *) let zoom_map f a expander introducer d = - let zoomed = zoom expander introducer d in - if not (Option.has_some zoomed) then - a - else - f (Option.get zoomed) + bind + (zoom expander introducer d) + (fun zoomed -> + if not (Option.has_some zoomed) then + ret a + else + ret (f (Option.get zoomed))) (* Zoom over two inductive proofs that induct over the same hypothesis *) -let zoom_same_hypos = zoom (fun c -> snd (expand_application c Evd.empty)) (fun d -> Some d) +let zoom_same_hypos = zoom expand_application (fun d -> ret (Some d)) (* Default zoom for recursive search *) -let zoom_search f (d : goal_proof_diff) : candidates = +let zoom_search f (d : goal_proof_diff) = zoom_map f give_up - (fun c -> snd (expand_terminal c Evd.empty)) + expand_terminal intro_common (erase_goals d) (* Zoom in, search, and wrap the result in a lambda from binding (n : t) *) -let zoom_wrap_lambda f n t (d : goal_proof_diff) : candidates = +let zoom_wrap_lambda f n t (d : goal_proof_diff) = zoom_search (fun d -> List.map (fun c -> mkLambda (n, t, c)) (f d)) d (* Zoom in, search, and wrap the result in a prod from binding (n : t) *) -let zoom_wrap_prod f n t (d : goal_proof_diff) : candidates = +let zoom_wrap_prod f n t (d : goal_proof_diff) = zoom_search (fun d -> List.map (fun c -> mkProd (n, t, c)) (f d)) d (* Zoom in, search, and unshift the result *) -let zoom_unshift f (d : goal_proof_diff) : candidates = +let zoom_unshift f (d : goal_proof_diff) = zoom_search (fun d -> List.map unshift (f d)) d diff --git a/plugin/src/compilation/categories/catzooming.mli b/plugin/src/compilation/categories/catzooming.mli index ab8815e..1547c63 100644 --- a/plugin/src/compilation/categories/catzooming.mli +++ b/plugin/src/compilation/categories/catzooming.mli @@ -5,11 +5,13 @@ open Proofcat open Candidates open Names open Constr +open Stateutils +open Evd (* --- Zooming --- *) type search_function = proof_cat_diff -> candidates -type 'a intro_strategy = 'a proof_diff -> 'a proof_diff option +type 'a intro_strategy = 'a proof_diff -> evar_map -> ('a proof_diff option) state (* * Zooming is what we call an operation that involves: @@ -37,13 +39,12 @@ type 'a intro_strategy = 'a proof_diff -> 'a proof_diff option * since that is not possible. *) -type 'a expansion_strategy_old = 'a -> 'a (* TODO remove me *) - type 'a zoomer = - 'a expansion_strategy_old -> + 'a expansion_strategy -> 'a intro_strategy -> 'a proof_diff -> - 'a proof_diff option + evar_map -> + ('a proof_diff option) state (* --- Introduction strategies --- *) @@ -96,36 +97,37 @@ val zoom : 'a zoomer val zoom_map : ('a proof_diff -> 'b) -> 'b -> - 'a expansion_strategy_old -> + 'a expansion_strategy -> 'a intro_strategy -> 'a proof_diff -> - 'b + evar_map -> + 'b state (* * Zoom over two inductive proofs that induct over the same hypothesis * Return the leftover arguments that aren't applied to the inductive type *) -val zoom_same_hypos : induction_diff -> induction_diff option +val zoom_same_hypos : induction_diff -> evar_map -> (induction_diff option) state (* * Default zoom for recursive search *) -val zoom_search : search_function -> goal_proof_diff -> candidates +val zoom_search : search_function -> goal_proof_diff -> evar_map -> candidates state (* * Zoom in, search, and wrap the result in a lambda *) val zoom_wrap_lambda : - search_function -> Name.t -> types -> goal_proof_diff -> candidates + search_function -> Name.t -> types -> goal_proof_diff -> evar_map -> candidates state (* * Zoom in, search, and wrap the result in a product *) val zoom_wrap_prod : - search_function -> Name.t -> types -> goal_proof_diff -> candidates + search_function -> Name.t -> types -> goal_proof_diff -> evar_map -> candidates state (* * Zoom in, search, and unshift the result *) -val zoom_unshift : search_function -> goal_proof_diff -> candidates +val zoom_unshift : search_function -> goal_proof_diff -> evar_map -> candidates state diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index b20424a..d3a8dd1 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -130,7 +130,7 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = let o = old_proof d_proofs in let n = new_proof d_proofs in let d_ind = difference (o, 0, []) (n, 0, []) (assumptions d) in - let d_opt = zoom_same_hypos d_ind in + let _, d_opt = zoom_same_hypos d_ind Evd.empty in if Option.has_some d_opt then let d_zoom = Option.get d_opt in let assums = assumptions d_zoom in diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index b96531f..a1725ad 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -102,9 +102,9 @@ let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidate let ind = is_ind opts in let opts_hypos = if is_identity change then set_change opts Conclusion else opts in if no_diff evd opts_hypos (snd (eval_with_terms t_o t_n d Evd.empty)) then - (*4*) zoom_wrap_lambda (to_search_function diff opts d) n_o t_o d + (*4*) snd (zoom_wrap_lambda (to_search_function diff opts d) n_o t_o d Evd.empty) else if ind || not (is_conclusion change || is_identity change) then - (*5*) zoom_unshift (to_search_function diff opts d) d + (*5*) snd (zoom_unshift (to_search_function diff opts d) d Evd.empty) else give_up | _ -> diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index efa7fa9..24ce345 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -17,6 +17,7 @@ open Expansion open Environ open Evd open Higherdifferencers +open Stateutils (* --- Cases --- *) @@ -189,13 +190,15 @@ let diff_inductive diff d_old opts evd (d : (proof_cat * int) proof_diff) : cand if not (nparams_o = nparams_n) then give_up else - zoom_map - (fun d -> - let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in - let d_sorted = map_diffs sort id d in - let ds = dest_cases d_sorted in - List.map (unshift_by nparams_o) (diff_ind_cases opts evd diff d_old ds)) - [] - id - (intro_params nparams_o) - (difference o n (assumptions d)) + snd + (zoom_map + (fun d -> + let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in + let d_sorted = map_diffs sort id d in + let ds = dest_cases d_sorted in + List.map (unshift_by nparams_o) (diff_ind_cases opts evd diff d_old ds)) + [] + ret + (intro_params nparams_o) + (difference o n (assumptions d)) + Evd.empty) From fce0845d337590a7702b94cb39e7c7bd82bc637d Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 19:01:47 -0700 Subject: [PATCH 116/154] searchopts evar_maps --- plugin/src/configuration/searchopts.ml | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index d88d615..ab723cd 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -13,23 +13,20 @@ open Cutlemma open Catzooming open Indutils open Contextutils +open Stateutils +open Convertibility (* * Note: Evar discipline is not good here yet, but will change when * we merge PUMPKIN with DEVOID and refactor. *) -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) - (* --- Auxiliary --- *) -let terms_convertible env_o env_n evd src_o src_n dst_o dst_n = - convertible env_o evd src_o dst_o && convertible env_n evd src_n dst_n +let terms_convertible env_o env_n src_o src_n = + and_state + (fun dst_o sigma -> convertible env_o sigma src_o dst_o) + (fun dst_n sigma -> convertible env_n sigma src_n dst_n) let context_envs = map_tuple context_env let context_terms = map_tuple context_term @@ -102,9 +99,9 @@ let configure_same_h change (d : lift_goal_diff) : types -> types -> bool = let env_n' = push_rel rel_n env_n in let (_, _, t_o) = CRD.to_tuple @@ rel_o in let (_, _, t_n) = CRD.to_tuple @@ rel_n in - let trim = terms_convertible env_o' env_n' Evd.empty t_o t_n in + let trim = terms_convertible env_o' env_n' t_o t_n in match map_tuple kind (g_o, g_n) with - | (Prod (_, t_g_o, b_o), Prod (_, t_g_n, b_n)) when trim t_g_o t_g_n -> + | (Prod (_, t_g_o, b_o), Prod (_, t_g_n, b_n)) when snd (trim t_g_o t_g_n Evd.empty) -> (Term (b_o, env_o'), Term (b_n, env_n')) | _ -> (Term (shift g_o, env_o'), Term (shift g_n, env_n')) From e6b26b9ba5ae02e9fa686311f36a1244dfc3ca36 Mon Sep 17 00:00:00 2001 From: tringer Date: Mon, 2 Sep 2019 19:24:56 -0700 Subject: [PATCH 117/154] WIP --- .../src/compilation/categories/catzooming.ml | 10 ++--- .../src/compilation/categories/catzooming.mli | 4 +- plugin/src/configuration/searchopts.ml | 40 ++++++++++++------- plugin/src/configuration/searchopts.mli | 6 ++- 4 files changed, 36 insertions(+), 24 deletions(-) diff --git a/plugin/src/compilation/categories/catzooming.ml b/plugin/src/compilation/categories/catzooming.ml index 71f0d78..675e4bb 100644 --- a/plugin/src/compilation/categories/catzooming.ml +++ b/plugin/src/compilation/categories/catzooming.ml @@ -12,7 +12,7 @@ open Evd (* --- Zooming --- *) -type search_function = proof_cat_diff -> candidates +type search_function = proof_cat_diff -> evar_map -> candidates state type 'a intro_strategy = 'a proof_diff -> evar_map -> ('a proof_diff option) state type 'a zoomer = @@ -154,7 +154,7 @@ let zoom_map f a expander introducer d = if not (Option.has_some zoomed) then ret a else - ret (f (Option.get zoomed))) + f (Option.get zoomed)) (* Zoom over two inductive proofs that induct over the same hypothesis *) let zoom_same_hypos = zoom expand_application (fun d -> ret (Some d)) @@ -171,17 +171,17 @@ let zoom_search f (d : goal_proof_diff) = (* Zoom in, search, and wrap the result in a lambda from binding (n : t) *) let zoom_wrap_lambda f n t (d : goal_proof_diff) = zoom_search - (fun d -> List.map (fun c -> mkLambda (n, t, c)) (f d)) + (fun d -> bind (f d) (map_state (fun c -> ret (mkLambda (n, t, c))))) d (* Zoom in, search, and wrap the result in a prod from binding (n : t) *) let zoom_wrap_prod f n t (d : goal_proof_diff) = zoom_search - (fun d -> List.map (fun c -> mkProd (n, t, c)) (f d)) + (fun d -> bind (f d) (map_state (fun c -> ret (mkProd (n, t, c))))) d (* Zoom in, search, and unshift the result *) let zoom_unshift f (d : goal_proof_diff) = zoom_search - (fun d -> List.map unshift (f d)) + (fun d -> bind (f d) (map_state (fun t -> ret (unshift t)))) d diff --git a/plugin/src/compilation/categories/catzooming.mli b/plugin/src/compilation/categories/catzooming.mli index 1547c63..50e6a29 100644 --- a/plugin/src/compilation/categories/catzooming.mli +++ b/plugin/src/compilation/categories/catzooming.mli @@ -10,7 +10,7 @@ open Evd (* --- Zooming --- *) -type search_function = proof_cat_diff -> candidates +type search_function = proof_cat_diff -> evar_map -> candidates state type 'a intro_strategy = 'a proof_diff -> evar_map -> ('a proof_diff option) state (* @@ -95,7 +95,7 @@ val zoom : 'a zoomer * Otherwise, default to a default element *) val zoom_map : - ('a proof_diff -> 'b) -> + ('a proof_diff -> evar_map -> 'b state) -> 'b -> 'a expansion_strategy -> 'a intro_strategy -> diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index ab723cd..7c0324b 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -15,6 +15,7 @@ open Indutils open Contextutils open Stateutils open Convertibility +open Evd (* * Note: Evar discipline is not good here yet, but will change when @@ -55,7 +56,7 @@ type options = is_ind : bool; change : kind_of_change; same_h : types -> types -> bool; - update_goals : goal_proof_diff -> proof_cat_diff -> goal_proof_diff; + update_goals : goal_proof_diff -> proof_cat_diff -> evar_map -> goal_proof_diff state; swap_goals : goal_term_diff -> goal_term_diff; reset_goals : goal_proof_diff -> goal_case_diff -> goal_case_diff; is_app : goal_proof_diff -> bool; @@ -101,10 +102,14 @@ let configure_same_h change (d : lift_goal_diff) : types -> types -> bool = let (_, _, t_n) = CRD.to_tuple @@ rel_n in let trim = terms_convertible env_o' env_n' t_o t_n in match map_tuple kind (g_o, g_n) with - | (Prod (_, t_g_o, b_o), Prod (_, t_g_n, b_n)) when snd (trim t_g_o t_g_n Evd.empty) -> - (Term (b_o, env_o'), Term (b_n, env_n')) + | (Prod (_, t_g_o, b_o), Prod (_, t_g_n, b_n)) -> + branch_state + (trim t_g_o) + (fun _ -> ret (Term (b_o, env_o'), Term (b_n, env_n'))) + (fun _ -> ret (Term (shift g_o, env_o'), Term (shift g_n, env_n'))) + t_g_n | _ -> - (Term (shift g_o, env_o'), Term (shift g_n, env_n')) + ret (Term (shift g_o, env_o'), Term (shift g_n, env_n')) (* Search for a difference in the changed constructor *) let set_inductive_goals typ_o typ_n (d : 'a goal_diff) : 'a goal_diff = @@ -129,14 +134,16 @@ let update_goals_types d_old (d : proof_cat_diff) = | (Lambda (n_o, t_o, _), Lambda (n_n, t_n, _)) -> let rel_o = CRD.LocalAssum(n_o, t_o) in let rel_n = CRD.LocalAssum(n_n, t_n) in - let (g_o, g_n) = update_goal_terms (old_goal, new_goal) rel_o rel_n in - let o = (Context (g_o, fid ()), old_proof d) in - let n = (Context (g_n, fid ()), new_proof d) in - difference o n (assumptions d) + bind + (update_goal_terms (old_goal, new_goal) rel_o rel_n) + (fun (g_o, g_n) -> + let o = (Context (g_o, fid ()), old_proof d) in + let n = (Context (g_n, fid ()), new_proof d) in + ret (difference o n (assumptions d))) | _ -> let o = (old_goal, old_proof d) in let n = (new_goal, new_proof d) in - difference o n (assumptions d) + ret (difference o n (assumptions d)) (* Set goals for search for a difference in hypothesis *) let set_hypothesis_goals t_o t_n (d : 'a goal_diff) : 'a goal_diff = @@ -167,11 +174,11 @@ let configure_update_goals change d_old d = let (g_o, g_n) = context_terms old_goals in let (g_o', g_n') = context_terms default_goals in if equal g_o g_o' && equal g_n g_n' then (* set initial goals *) - set_hypothesis_goals t_old t_new d_def + ret (set_hypothesis_goals t_old t_new d_def) else (* update goals *) update_goals_types d_old d | _ -> - add_goals d + ret (add_goals d) (* * Given a change, determine how to test whether a proof might apply @@ -272,12 +279,15 @@ let is_ind opts = opts.is_ind (* Keep the same assumptions, but update the goals and terms for a diff *) let update_terms_goals opts t_o t_n d = let update = update_search_goals opts d in - update (erase_goals (snd (eval_with_terms t_o t_n d Evd.empty))) + bind + (eval_with_terms t_o t_n d) + (fun d -> update (erase_goals d)) (* Convert search to a search_function for zooming *) -let to_search_function search opts d : search_function = - let update_goals = update_search_goals opts d in - (fun d -> search opts (update_goals d)) +let to_search_function search opts d = + ret + (fun d' -> + bind (update_search_goals opts d d') (fun _ -> ret (search opts))) (* * Check if a term applies the inductive hypothesis diff --git a/plugin/src/configuration/searchopts.mli b/plugin/src/configuration/searchopts.mli index a688756..0823508 100644 --- a/plugin/src/configuration/searchopts.mli +++ b/plugin/src/configuration/searchopts.mli @@ -6,6 +6,8 @@ open Cutlemma open Kindofchange open Candidates open Catzooming +open Evd +open Stateutils (* --- Options for search --- *) @@ -30,7 +32,7 @@ val set_change : options -> kind_of_change -> options (* Update the goals of search *) val update_search_goals : - (goal_proof_diff -> proof_cat_diff -> goal_proof_diff) configurable + (goal_proof_diff -> proof_cat_diff -> evar_map -> goal_proof_diff state) configurable (* Swap the goals of search *) val swap_search_goals : (goal_term_diff -> goal_term_diff) configurable @@ -62,7 +64,7 @@ val is_ind : bool configurable * and replace the terms with the supplied old and new types. *) val update_terms_goals : - (types -> types -> goal_proof_diff -> goal_proof_diff) configurable + (types -> types -> goal_proof_diff -> evar_map -> goal_proof_diff state) configurable (* * Convert a search function that takes a set of options to a From 8aa5e77a9af1a9d3f74ddbcd4b0ed46740b28e1a Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 11:01:49 -0700 Subject: [PATCH 118/154] update dep --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index c008a39..0e53b2d 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit c008a39c3168ea663eb81cef31e72386d5a0b82c +Subproject commit 0e53b2d51f253daac8db6fe21b035ea90701db73 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 43c5217..3f7201f 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 43c5217730e2124db624c3cbe9457b88a85c5eda +Subproject commit 3f7201fca529639ea85299e81defae279e387047 From 2d653d1ffa49c69ce985e3b3d53c60db670663b5 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 11:16:42 -0700 Subject: [PATCH 119/154] Fix searchopts state --- plugin/src/configuration/searchopts.ml | 5 ++--- .../src/core/components/differencing/higherdifferencers.ml | 2 +- plugin/src/core/components/differencing/inddifferencers.ml | 4 ++-- plugin/src/core/procedures/search.ml | 2 +- 4 files changed, 6 insertions(+), 7 deletions(-) diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index 7c0324b..948c0af 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -285,9 +285,8 @@ let update_terms_goals opts t_o t_n d = (* Convert search to a search_function for zooming *) let to_search_function search opts d = - ret - (fun d' -> - bind (update_search_goals opts d d') (fun _ -> ret (search opts))) + (fun d' -> + bind (update_search_goals opts d d') (fun d -> ret (search opts d))) (* * Check if a term applies the inductive hypothesis diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index f6c52a9..bd6cea2 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -45,7 +45,7 @@ let diff_reduced diff d = * 2. Apply the differencing function to the new diff *) let diff_terms (diff : proof_differencer) d opts d_t : candidates = - diff (update_terms_goals opts (old_proof d_t) (new_proof d_t) d) + diff (snd (update_terms_goals opts (old_proof d_t) (new_proof d_t) d Evd.empty)) (* * Recursively difference each term in a diff of arrays diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 24ce345..423d193 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -192,11 +192,11 @@ let diff_inductive diff d_old opts evd (d : (proof_cat * int) proof_diff) : cand else snd (zoom_map - (fun d -> + (fun d sigma -> let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in let d_sorted = map_diffs sort id d in let ds = dest_cases d_sorted in - List.map (unshift_by nparams_o) (diff_ind_cases opts evd diff d_old ds)) + map_state (fun d -> ret (unshift_by nparams_o d)) (diff_ind_cases opts evd diff d_old ds) Evd.empty) [] ret (intro_params nparams_o) diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index 4410890..0f85b15 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -83,7 +83,7 @@ let search_for_patch evd (default : types) (opts : options) (d : goal_proof_diff let change = get_change opts in let start_backwards = is_fixpoint_case change || is_hypothesis change in let d = if start_backwards then reverse d else d in (* explain *) - let d = update_search_goals opts d (erase_goals d) in + let d = snd (update_search_goals opts d (erase_goals d) Evd.empty) in let diff = get_differencer opts evd in let patches = diff d in let ((_, env), _) = old_proof (dest_goals d) in From 6ca4a75890b32b8ee32630ba0879e52cd9e9604e Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 11:34:54 -0700 Subject: [PATCH 120/154] specialization state --- .../components/abstraction/abstraction.ml | 8 ++++--- .../differencing/appdifferencers.ml | 4 ++-- .../core/components/factoring/factoring.ml | 2 +- .../specialization/specialization.ml | 24 ++++++++++--------- .../specialization/specialization.mli | 4 +++- plugin/src/core/procedures/theorem.ml | 2 +- 6 files changed, 25 insertions(+), 19 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index b38c868..01bc980 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -27,6 +27,8 @@ open Convertibility * Infer the type of trm in env * Note: This does not yet use good evar map hygeine; will fix that * during the refactor. + * + * TODO remove once evar_map refactor is done (needs to be last) *) let infer_type (env : env) (evd : evar_map) (trm : types) : types = let jmt = Typeops.infer env trm in @@ -108,7 +110,7 @@ let get_concrete config strategy : closure = let evd = config.evd in let args = config.args_base in let s = reducer_to_specializer reduce_term in - let base = specialize_using s env evd config.f_base (Array.of_list args) in + let evd, base = specialize_using s env config.f_base (Array.of_list args) evd in let concrete = (env, List.append args [base]) in match kind_of_abstraction strategy with | Arguments -> @@ -140,13 +142,13 @@ let get_abstract config concrete strategy : closure = | Arguments -> let (env_abs, args_abs) = get_abstraction_args config in let p = shift_by (List.length args_abs) config.f_base in - let base_abs = specialize_using s env_abs evd p (Array.of_list args_abs) in + let evd, base_abs = specialize_using s env_abs p (Array.of_list args_abs) evd in (env_abs, List.append args_abs [base_abs]) | Property -> let args_abs = config.args_base in let (env_p, args_p) = concrete in let p = mkRel (nb_rel env_p) in - let base_abs = specialize_using s env_p evd p (Array.of_list args_abs) in + let evd, base_abs = specialize_using s env_p p (Array.of_list args_abs) evd in (env_p, List.append (p :: List.tl args_abs) [base_abs]) (* Given a abstraction strategy, get the abstraction options for the diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index d3a8dd1..129aa19 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -106,7 +106,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi filter_diff_h (diff_map_flat (diff_rec diff_arg opts)) d_args | Kindofchange.Conclusion | Kindofchange.Identity -> if List.for_all2 (convertible env evd) (Array.to_list args_o) (Array.to_list args_n) then - let specialize = specialize_using specialize_no_reduce env evd in + let specialize f args = snd (specialize_using specialize_no_reduce env f args evd) in let combine_app = combine_cartesian specialize in let fs = diff_rec diff_f opts d_f in let args = Array.map (fun a_o -> [a_o]) args_o in @@ -165,7 +165,7 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = 0 in let arity = prop_arity prop_trm in - let specialize = specialize_using specialize_no_reduce env_o evd in + let specialize f args = snd (specialize_using specialize_no_reduce env_o f args evd) in let final_args_o = Array.of_list (fst (split_at arity args_o)) in if Kindofchange.is_identity (get_change opts) then (* TODO explain *) List.map diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index 10054c3..de8e5b2 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -144,7 +144,7 @@ let apply_factors evd (fs : factors) : types = let body = List.fold_right (fun (en, t) t_app -> - specialize_using specialize_no_reduce en evd (shift t) (Array.make 1 t_app)) + snd (specialize_using specialize_no_reduce en (shift t) (Array.make 1 t_app) evd)) (List.tl fs) base in reconstruct_lambda env body diff --git a/plugin/src/core/components/specialization/specialization.ml b/plugin/src/core/components/specialization/specialization.ml index 70fb824..19491ca 100644 --- a/plugin/src/core/components/specialization/specialization.ml +++ b/plugin/src/core/components/specialization/specialization.ml @@ -16,13 +16,14 @@ open Reducers open Utilities open Contextutils open Envutils +open Stateutils -type specializer = env -> evar_map -> types -> types array -> types +type specializer = env -> types -> types array -> evar_map -> types state (* --- Top-level --- *) -let specialize_using (s : specializer) env evd f args = - s env evd f args +let specialize_using (s : specializer) env f args = + s env f args (* --- Conversion between specializers and reducers --- *) @@ -37,31 +38,32 @@ let specialize_using (s : specializer) env evd f args = * This will delta-reduce the function f if necessary. * At the bottom level, it returns betaiota reduction. *) -let rec specialize_body (s : specializer) (env : env) (evd : evar_map) (t : types) = +let rec specialize_body (s : specializer) (env : env) sigma (t : types) = match kind t with | Lambda (n, t, b) -> - let evd, b = specialize_body s (push_local (n, t) env) evd b in - evd, mkLambda (n, t, b) + bind + (fun sigma -> specialize_body s (push_local (n, t) env) sigma b) + (fun b -> ret (mkLambda (n, t, b))) + sigma | App (f, args) -> - let f_body = unwrap_definition env f in - evd, s env evd f_body args + s env (unwrap_definition env f) args sigma | _ -> failwith "Term should be of the form (fun args => f args)" (* Convert a specializer into a reducer by taking arguments *) let specialize_to (args : types array) (s : specializer) : reducer = - fun env evd f -> evd, s env evd f args + fun env sigma f -> s env f args sigma (* * Convert a specializer into a reducer by taking the function * This only handles a single argument *) let specialize_in (f : types) (s : specializer) : reducer = - fun env evd arg -> evd, s env evd f (Array.make 1 arg) + fun env sigma arg -> s env f (Array.make 1 arg) sigma (* Convert a reducer into a specializer in the obvious way *) let reducer_to_specializer (r : reducer) : specializer = - fun env evd f args -> snd (r env evd (mkApp (f, args))) + fun env f args sigma -> r env sigma (mkApp (f, args)) (* --- Defaults --- *) diff --git a/plugin/src/core/components/specialization/specialization.mli b/plugin/src/core/components/specialization/specialization.mli index 771c501..f13bba2 100644 --- a/plugin/src/core/components/specialization/specialization.mli +++ b/plugin/src/core/components/specialization/specialization.mli @@ -13,6 +13,7 @@ open Constr open Environ open Evd open Reducers +open Stateutils (* * A reducer specializes within a term. @@ -23,7 +24,8 @@ type specializer (* --- Top-level --- *) -val specialize_using : specializer -> env -> evar_map -> types -> types array -> types +val specialize_using : + specializer -> env -> types -> types array -> evar_map -> types state (* --- Defaults --- *) diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index ba3c7d9..e32c96d 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -99,7 +99,7 @@ let update_theorem env evd (src : types) (dst : types) (trm : types) : types = let (env, trm) = zoom_lambda_term env trm in let _, trm = reduce_term env evd trm in let (env_args, args) = args_to env evd src trm in - let specialize = specialize_using specialize_no_reduce env_args evd in + let specialize f args = snd (specialize_using specialize_no_reduce env_args f args evd) in let src_typ = infer_type env_args evd (specialize src args) in let dst_typ = infer_type env_args evd (specialize dst args) in let (env_s, src_concl) = zoom_product_type env_args src_typ in From 3003316fd1f10ba135f646d53045d1d74c863c0f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 11:52:32 -0700 Subject: [PATCH 121/154] abstracters with state --- .../components/abstraction/abstracters.ml | 86 ++++++++++++------- .../components/abstraction/abstracters.mli | 22 ++++- .../components/abstraction/abstraction.ml | 6 +- 3 files changed, 74 insertions(+), 40 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstracters.ml b/plugin/src/core/components/abstraction/abstracters.ml index 173ebaa..a09d681 100644 --- a/plugin/src/core/components/abstraction/abstracters.ml +++ b/plugin/src/core/components/abstraction/abstracters.ml @@ -12,7 +12,8 @@ open Convertibility open Stateutils type abstraction_dimension = Arguments | Property -type abstracter = env -> evar_map -> types -> types -> candidates -> candidates +type abstracter = + env -> types -> types -> candidates -> evar_map -> candidates state type abstraction_strategy = { @@ -51,36 +52,38 @@ let sort_dependent args args_abstract = * Substitute actual args with abstract args in candidates, * using an abstracter to determine when to substitute. *) -let substitute_using (strategy : abstraction_strategy) (env : env) (evd : evar_map) (args : types list) (args_abstract : types list) (cs : candidates) : candidates = +let substitute_using strategy env args args_abstract cs = let abs = strategy.abstracter in let num_args = List.length args_abstract in let (args_sorted, args_abstract_sorted) = if strategy.to_abstract = Property then - (List.rev args, List.rev args_abstract) (* TODO refactor/simplify *) + List.rev args, List.rev args_abstract (* TODO refactor/simplify *) else sort_dependent args args_abstract in if num_args > 0 then - let cs_abs = abs env evd (last args_sorted) (last args_abstract_sorted) cs in - List.fold_right2 - (abs env evd) - (all_but_last args_sorted) - (all_but_last args_abstract_sorted) - cs_abs + bind + (abs env (last args_sorted) (last args_abstract_sorted) cs) + (fun cs_abs -> + fold_left2_state + (fun cs t1 t2 sigma -> abs env t1 t2 cs sigma) + cs_abs + (List.rev (all_but_last args_sorted)) + (List.rev (all_but_last args_abstract_sorted))) else - [] + ret [] (* * Reduce using the reducer in the abstraction strategy *) -let reduce_all_using strategy env evd (cs : candidates) : candidates state = - reduce_all strategy.reducer env evd cs +let reduce_all_using strategy env (cs : candidates) sigma = + reduce_all strategy.reducer env sigma cs (* * Filter using the filter in the abstraction stragegy *) -let filter_using strategy env evd (goal : types) (cs : candidates) : candidates state = - strategy.filter goal env evd cs +let filter_using strategy env (goal : types) (cs : candidates) sigma = + strategy.filter goal env sigma cs (* --- Recover options from an abstraction strategy --- *) @@ -95,58 +98,75 @@ let kind_of_abstraction strategy = strategy.to_abstract (* TODO rename syntactic strategies, makes less sense given pattern *) (* Fully abstract each term, substituting every convertible subterm *) -let syntactic_full env evd (arg_actual : types) (arg_abstract : types) (trms : candidates) : candidates = +let syntactic_full env (arg_actual : types) (arg_abstract : types) (trms : candidates) = if equal arg_actual arg_abstract then - trms + ret trms else - List.map (fun tr -> snd (all_conv_substs env evd (arg_actual, arg_abstract) tr)) trms (* TODO evar_maps *) + map_state + (fun tr sigma -> all_conv_substs env sigma (arg_actual, arg_abstract) tr) + trms let syntactic_full_strategy : abstracter = syntactic_full (* Fully abstract each term, substituting every subterm w/ convertible types *) -let types_full env evd (arg_actual : types) (arg_abstract : types) (trms : candidates) : candidates = +let types_full env (arg_actual : types) (arg_abstract : types) (trms : candidates) = if equal arg_actual arg_abstract then - trms + ret trms else - List.map (fun tr -> snd (all_typ_substs env evd (arg_actual, arg_abstract) tr)) trms (* TODO evar_maps *) + map_state + (fun tr sigma -> all_typ_substs env sigma (arg_actual, arg_abstract) tr) + trms let types_full_strategy : abstracter = types_full (* A pattern-based full abstraction strategy for functions *) (* TODO really just need a more flexible top-level function that lets you combine strategies *) -let function_pattern_full (env : env) (evd : evar_map) (arg_actual : types) (arg_abstract : types) (trms : types list) : types list = +let function_pattern_full (env : env) (arg_actual : types) (arg_abstract : types) (trms : types list)= match kind arg_abstract with | App (f, args) -> - syntactic_full env evd arg_actual arg_abstract trms + syntactic_full env arg_actual arg_abstract trms | _ -> - types_full env evd arg_actual arg_abstract trms + types_full env arg_actual arg_abstract trms let function_pattern_full_strategy : abstracter = function_pattern_full (* A pattern-based full abstraction strategy for constructors *) -let pattern_full (env : env) (evd : evar_map) (arg_actual : types) (arg_abstract : types) (trms : types list) : types list = - let types_conv trm evd = types_convertible env evd arg_abstract trm in +let pattern_full (env : env) (arg_actual : types) (arg_abstract : types) (trms : types list) = + let types_conv trm sigma = types_convertible env sigma arg_abstract trm in let exists_types_conv = exists_state types_conv in match map_tuple kind (arg_actual, arg_abstract) with - | (App (f, args), _) when snd (exists_types_conv (Array.to_list args) evd) -> - let _, arg = find_state types_conv (Array.to_list args) evd in - let sub tr = snd (all_constr_substs env evd f tr) in (* TODO evar_map *) - syntactic_full env evd arg arg_abstract (List.map sub trms) + | (App (f, args), _) -> + branch_state + (fun args -> exists_types_conv args) + (fun args -> + bind + (find_state types_conv args) + (fun arg -> + bind + (map_state + (fun tr sigma -> all_constr_substs env sigma f tr) + trms) + (syntactic_full env arg arg_abstract))) + (fun _ -> ret trms) + (Array.to_list args) | _ -> - trms + ret trms let pattern_full_strategy : abstracter = pattern_full (* All combinations of abstractions of convertible subterms *) -let syntactic_all_combinations env evd (arg_actual : types) (arg_abstract : types) (trms : candidates) : candidates = +let syntactic_all_combinations env (arg_actual : types) (arg_abstract : types) (trms : candidates) = if equal arg_actual arg_abstract then - trms + ret trms else - flat_map (fun tr -> snd (all_conv_substs_combs env evd (arg_actual, arg_abstract) tr)) trms (* TODO evar_map *) + flat_map_state + (fun tr sigma -> + all_conv_substs_combs env sigma (arg_actual, arg_abstract) tr) + trms let syntactic_all_strategy : abstracter = syntactic_all_combinations diff --git a/plugin/src/core/components/abstraction/abstracters.mli b/plugin/src/core/components/abstraction/abstracters.mli index fcbb74e..b4ed259 100644 --- a/plugin/src/core/components/abstraction/abstracters.mli +++ b/plugin/src/core/components/abstraction/abstracters.mli @@ -17,22 +17,36 @@ type abstraction_strategy * using a strategy to determine when to substitute. *) val substitute_using : - abstraction_strategy -> env -> evar_map -> types list -> types list -> candidates -> - candidates + abstraction_strategy -> + env -> + types list -> + types list -> + candidates -> + evar_map -> + candidates state (* * Reduce candidates, using the abstraction strategy to determine * how to reduce *) val reduce_all_using : - abstraction_strategy -> env -> evar_map -> candidates -> candidates state + abstraction_strategy -> + env -> + candidates -> + evar_map -> + candidates state (* * Filter candidates, using the abstraction strategy to determine * how to filter *) val filter_using : - abstraction_strategy -> env -> evar_map -> types -> candidates -> candidates state + abstraction_strategy -> + env -> + types -> + candidates -> + evar_map -> + candidates state (* --- Recover options from an abstraction strategy --- *) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 01bc980..5230a76 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -174,14 +174,14 @@ let abstract_with_strategy (config : abstraction_config) strategy : candidates = let evd = config.evd in let (env, args) = opts.concrete in let (env_abs, args_abs) = opts.abstract in - let _, reduced_cs = reduce_all_using strategy env evd config.cs in + let _, reduced_cs = reduce_all_using strategy env config.cs evd in let shift_concrete = List.map (shift_by (nb_rel env_abs - nb_rel env)) in let args_adj = shift_concrete args in let cs_adj = shift_concrete reduced_cs in - let bs = substitute_using strategy env_abs evd args_adj args_abs cs_adj in + let _, bs = substitute_using strategy env_abs args_adj args_abs cs_adj evd in let lambdas = generalize env_abs evd opts.num_to_abstract bs in Printf.printf "%d abstracted candidates\n" (List.length lambdas); - snd (filter_using strategy env evd opts.goal_type lambdas) + snd (filter_using strategy env opts.goal_type lambdas evd) (* * Try to abstract candidates with an ordered list of abstraction strategies From 5e435fca0b9347e53d90460211ab725ca8e5295c Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 13:53:06 -0700 Subject: [PATCH 122/154] abstraction_config with state --- .../components/abstraction/abstraction.ml | 26 ++++--- .../components/abstraction/abstraction.mli | 2 +- .../abstraction/abstractionconfig.ml | 70 ++++++++++--------- .../abstraction/abstractionconfig.mli | 26 +++++-- plugin/src/core/procedures/search.ml | 15 ++-- plugin/src/patcher.ml4 | 4 +- 6 files changed, 79 insertions(+), 64 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 5230a76..749d22f 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -20,6 +20,7 @@ open Contextutils open Merging open Apputils open Convertibility +open Stateutils (* --- TODO for refactoring without breaking things --- *) @@ -105,9 +106,8 @@ let get_concrete_prop (config : abstraction_config) (concrete : closure) : closu (env, p :: (List.tl args)) (* Get the concrete environment and arguments to abstract *) -let get_concrete config strategy : closure = +let get_concrete config strategy evd : closure = let env = config.env in - let evd = config.evd in let args = config.args_base in let s = reducer_to_specializer reduce_term in let evd, base = specialize_using s env config.f_base (Array.of_list args) evd in @@ -135,9 +135,8 @@ let get_abstraction_args config : closure = (* Get the abstract arguments that map to concrete arguments for a particular strategy, function, and arguments *) -let get_abstract config concrete strategy : closure = +let get_abstract config concrete strategy evd : closure = let s = reducer_to_specializer reduce_term in - let evd = config.evd in match kind_of_abstraction strategy with | Arguments -> let (env_abs, args_abs) = get_abstraction_args config in @@ -154,9 +153,9 @@ let get_abstract config concrete strategy : closure = (* Given a abstraction strategy, get the abstraction options for the particular function and arguments *) (* TODO num_to_abstract uniformity *) -let get_abstraction_opts config strategy : abstraction_options = - let concrete = get_concrete config strategy in - let abstract = get_abstract config concrete strategy in +let get_abstraction_opts config strategy evd : abstraction_options = + let concrete = get_concrete config strategy evd in + let abstract = get_abstract config concrete strategy evd in match kind_of_abstraction strategy with | Arguments -> let goal_type = get_arg_abstract_goal_type config in @@ -169,9 +168,8 @@ let get_abstraction_opts config strategy : abstraction_options = { concrete; abstract; goal_type; num_to_abstract } (* Abstract candidates with a provided abstraction strategy *) -let abstract_with_strategy (config : abstraction_config) strategy : candidates = - let opts = get_abstraction_opts config strategy in - let evd = config.evd in +let abstract_with_strategy (config : abstraction_config) strategy evd : candidates = + let opts = get_abstraction_opts config strategy evd in let (env, args) = opts.concrete in let (env_abs, args_abs) = opts.abstract in let _, reduced_cs = reduce_all_using strategy env config.cs evd in @@ -188,12 +186,12 @@ let abstract_with_strategy (config : abstraction_config) strategy : candidates = * Return as soon as one is successful * If all fail, return the empty list *) -let abstract_with_strategies (config : abstraction_config) : candidates = +let abstract_with_strategies (config : abstraction_config) evd : candidates = let abstract_using = abstract_with_strategy config in let rec try_abstract_using strategies = match strategies with | h :: t -> - let abstracted = abstract_using h in + let abstracted = abstract_using h evd in if (List.length abstracted) > 0 then abstracted else @@ -223,11 +221,11 @@ let try_abstract_inductive evd (d : lift_goal_diff) (cs : candidates) : candidat let new_goal_type = new_proof d_type in let old_goal_type = old_proof d_type in if List.for_all2 (fun t1 t2 -> snd (convertible env evd t1 t2)) (unfold_args old_goal_type) (unfold_args new_goal_type) then - let config = configure_args env evd d_type cs in + let _, config = configure_args env d_type cs evd in let num_new_rels = num_new_bindings snd (dest_lift_goals d) in List.map (unshift_local (num_new_rels - 1) num_new_rels) - (abstract_with_strategies config) + (abstract_with_strategies config evd) else give_up else diff --git a/plugin/src/core/components/abstraction/abstraction.mli b/plugin/src/core/components/abstraction/abstraction.mli index 80a6f84..20152c3 100644 --- a/plugin/src/core/components/abstraction/abstraction.mli +++ b/plugin/src/core/components/abstraction/abstraction.mli @@ -14,7 +14,7 @@ open Searchopts * Return as soon as one is successful * If all fail, return the empty list *) -val abstract_with_strategies : abstraction_config -> types list +val abstract_with_strategies : abstraction_config -> evar_map -> types list (* * Abstract candidates in a case of an inductive proof. diff --git a/plugin/src/core/components/abstraction/abstractionconfig.ml b/plugin/src/core/components/abstraction/abstractionconfig.ml index 74d5b22..a8b3576 100644 --- a/plugin/src/core/components/abstraction/abstractionconfig.ml +++ b/plugin/src/core/components/abstraction/abstractionconfig.ml @@ -1,5 +1,4 @@ open Environ -open Evd open Constr open Abstracters open Candidates @@ -10,6 +9,7 @@ open Cutlemma open Contextutils open Envutils open Inference +open Stateutils (* --- Configuring Abstraction --- *) @@ -21,7 +21,6 @@ open Inference type abstraction_config = { env : env; - evd : evar_map; args_base : types list; args_goal : types list; cs : candidates; @@ -42,12 +41,12 @@ let default_fun_strategies = reduce_strategies_prop * * TODO clean and document arg case *) -let rec configure_goal_body env evd goal c : abstraction_config = +let rec configure_goal_body env goal c sigma : abstraction_config state = match map_tuple kind (goal, c) with | (Prod (_, _, gb), Lambda (n, t, cb)) when isProd gb && isLambda cb -> - configure_goal_body (push_rel CRD.(LocalAssum(n, t)) env) evd gb cb + configure_goal_body (push_rel CRD.(LocalAssum(n, t)) env) gb cb sigma | (Prod (_, gt, gb), Lambda (_, _, _)) when isApp gt && isApp gb -> - let evd, c_typ = infer_type env evd c in + let sigma, c_typ = infer_type env sigma c in let (_, ctt, ctb) = destProd c_typ in if isApp ctb then let cs = [c] in @@ -62,14 +61,14 @@ let rec configure_goal_body env evd goal c : abstraction_config = let args_goal = args_base in let f_goal = unwrap_definition env f_goal in let strategies = default_arg_strategies in - {env; evd; args_base; args_goal; cs; f_base; f_goal; strategies} + sigma, {env; args_base; args_goal; cs; f_base; f_goal; strategies} else failwith "Cannot infer argument to abstract" else (* function *) let f_base = unwrap_definition env (fst (destApp (unshift ctb))) in let f_goal = f_base in let strategies = default_fun_strategies in - {env; evd; args_base; args_goal; cs; f_base; f_goal; strategies} + sigma, {env; args_base; args_goal; cs; f_base; f_goal; strategies} else failwith "Cannot infer function or argument to abstract" | _ -> @@ -81,7 +80,7 @@ let rec configure_goal_body env evd goal c : abstraction_config = * Default configuration for abstracting arguments for a list of candidates, * given the difference in goals d_type in a common environment env *) -let configure_args env evd (d_type : types proof_diff) cs = +let configure_args env (d_type : types proof_diff) cs = let new_goal_type = new_proof d_type in let old_goal_type = old_proof d_type in let (f_base, args_n) = destApp new_goal_type in @@ -89,7 +88,7 @@ let configure_args env evd (d_type : types proof_diff) cs = let args_base = Array.to_list args_n in let args_goal = args_base in let strategies = default_arg_strategies in - {env; evd; args_base; args_goal; cs; f_base; f_goal; strategies} + ret {env; args_base; args_goal; cs; f_base; f_goal; strategies} (* * Apply a dependent proposition at an index to the goal @@ -113,15 +112,16 @@ let rec apply_prop pi goal = * * We should check this is actually well-typed *) -let rec push_prop env evd typ : env = +let rec push_prop env typ = match kind typ with | Prod (n, t, b) -> - push_prop (push_rel CRD.(LocalAssum(n, t)) env) evd b + push_prop (push_local (n, t) env) b | App (f, _) -> - let evd, f_typ = infer_type env evd f in - push_rel - CRD.(LocalAssum(Names.Name.Anonymous, f_typ)) - (pop_rel_context (nb_rel env) env) + bind + (fun sigma -> infer_type env sigma f) + (fun typ -> + let env = pop_rel_context (nb_rel env) env in + ret (push_local (Names.Name.Anonymous, typ) env)) | _ -> failwith "Could not find function to abstract" @@ -130,25 +130,25 @@ let rec push_prop env evd typ : env = * Take an environment, a list of differences between those cases, * and a list of candidates *) -let configure_fixpoint_cases env evd (diffs : types list) (cs : candidates) = +let configure_fixpoint_cases env (diffs : types list) (cs : candidates) = let goals = List.map (apply_prop 1) diffs in - flat_map + flat_map_state (fun goal -> - List.map + map_state (fun c -> - let evd, prop = infer_type env evd c in - let env_prop = push_prop env evd prop in - configure_goal_body env_prop evd goal c) + bind + (bind (fun sigma -> infer_type env sigma c) (push_prop env)) + (fun env_prop -> configure_goal_body env_prop goal c)) cs) goals (* --- Cut Lemmas --- *) (* Given some cut lemma application, configure arguments to abstract *) -let rec configure_args_cut_app env evd (app : types) cs : abstraction_config = +let rec configure_args_cut_app env (app : types) cs = match kind app with | Lambda (n, t, b) -> - configure_args_cut_app (push_rel CRD.(LocalAssum(n, t)) env) evd b cs + configure_args_cut_app (push_local (n, t) env) b cs | App (f, args) -> let rec get_lemma_functions typ = match kind typ with @@ -160,22 +160,24 @@ let rec configure_args_cut_app env evd (app : types) cs : abstraction_config = | _ -> failwith "Could not infer arguments to generalize" in - let evd, f_typ = infer_type env evd f in - let (f_base, f_goal) = get_lemma_functions f_typ in - let args_base = Array.to_list args in - let args_goal = args_base in - let strategies = no_reduce_strategies in - {env; evd; args_base; args_goal; cs; f_base; f_goal; strategies} + bind + (fun sigma -> infer_type env sigma f) + (fun f_typ -> + let (f_base, f_goal) = get_lemma_functions f_typ in + let args_base = Array.to_list args in + let args_goal = args_base in + let strategies = no_reduce_strategies in + ret {env; args_base; args_goal; cs; f_base; f_goal; strategies}) | _ -> failwith "Ill-formed cut lemma" (* Configure abstraction over arguments when cutting by a cut lemma *) -let configure_cut_args env evd (cut : cut_lemma) (cs : candidates) = +let configure_cut_args env (cut : cut_lemma) (cs : candidates) = let cs = filter_consistent_cut env cut cs in if List.length cs > 0 then let (_, _, b) = destLambda (get_app cut) in - let env_cut = push_rel CRD.(LocalAssum(Names.Name.Anonymous, get_lemma cut)) env in - configure_args_cut_app env_cut evd b cs + let env_cut = push_local (Names.Name.Anonymous, get_lemma cut) env in + configure_args_cut_app env_cut b cs else failwith "No candidates are consistent with the cut lemma type" @@ -188,7 +190,7 @@ let configure_cut_args env evd (cut : cut_lemma) (cs : candidates) = * Eventually, we would like to handle multiple cs without * one configuration for each c. Same for the fixpoint case. *) -let configure_from_goal env evd goal c : abstraction_config = +let configure_from_goal env goal c = let (n, t, goal_body) = destProd goal in - configure_goal_body (push_rel CRD.(LocalAssum(n, t)) env) evd goal_body c + configure_goal_body (push_local (n, t) env) goal_body c diff --git a/plugin/src/core/components/abstraction/abstractionconfig.mli b/plugin/src/core/components/abstraction/abstractionconfig.mli index 89b4eac..c80d6fa 100644 --- a/plugin/src/core/components/abstraction/abstractionconfig.mli +++ b/plugin/src/core/components/abstraction/abstractionconfig.mli @@ -5,6 +5,7 @@ open Abstracters open Candidates open Proofdiff open Cutlemma +open Stateutils (* --- Configuring Abstraction --- *) @@ -12,7 +13,6 @@ open Cutlemma type abstraction_config = { env : env; - evd : evar_map; args_base : types list; args_goal : types list; cs : candidates; @@ -28,7 +28,11 @@ type abstraction_config = * configure the default configuration for abstraction of arguments *) val configure_args : - env -> evar_map -> types proof_diff -> candidates -> abstraction_config + env -> + types proof_diff -> + candidates -> + evar_map -> + abstraction_config state (* * Given an environment, a list of differences between fixpoint cases, @@ -37,7 +41,11 @@ val configure_args : * This produces one configuration for each difference. *) val configure_fixpoint_cases : - env -> evar_map -> types list -> candidates -> abstraction_config list + env -> + types list -> + candidates -> + evar_map -> + (abstraction_config list) state (* --- Cut Lemmas --- *) @@ -54,7 +62,11 @@ val configure_fixpoint_cases : * configure argument abstraction. *) val configure_cut_args : - env -> evar_map -> cut_lemma -> candidates -> abstraction_config + env -> + cut_lemma -> + candidates -> + evar_map -> + abstraction_config state (* --- Goals --- *) @@ -72,4 +84,8 @@ val configure_cut_args : * Automatically infer which kind of abstraction to try from the goal type. *) val configure_from_goal : - env -> evar_map -> types -> types -> abstraction_config + env -> + types -> + types -> + evar_map -> + abstraction_config state diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index 0f85b15..c578882 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -52,19 +52,18 @@ let return_patch opts env evd (patches : types list) : types = let specialized_fs_terms = flat_map reconstruct_factors specialized_fs in let generalized = flat_map - abstract_with_strategies - (configure_fixpoint_cases + (fun ss -> abstract_with_strategies ss evd) + (snd (configure_fixpoint_cases env - evd (diff_fix_cases env evd (difference old_type new_type no_assumptions)) - specialized_fs_terms) + specialized_fs_terms + evd)) in List.hd generalized (* TODO better failure when none found *) | ConclusionCase (Some cut) -> let _, patches = reduce_all remove_unused_hypos env evd patches in - let generalized = - abstract_with_strategies - (configure_cut_args env evd cut patches) - in List.hd generalized (* TODO better failure when none found *) + let evd, strategies = configure_cut_args env cut patches evd in + let generalized = abstract_with_strategies strategies evd in + List.hd generalized (* TODO better failure when none found *) | Hypothesis (_, _) -> let _, patches = reduce_all remove_unused_hypos env evd patches in List.hd patches diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index c2e0611..6244a7e 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -207,8 +207,8 @@ let abstract n trm goal : unit = let c = lookup_definition env def in let evm, goal_def = intern env evm goal in let goal_type = unwrap_definition env goal_def in - let config = configure_from_goal env evm goal_type c in - let abstracted = abstract_with_strategies config in + let evm, config = configure_from_goal env goal_type c evm in + let abstracted = abstract_with_strategies config evm in if List.length abstracted > 0 then try ignore (define_term n evm (List.hd abstracted) false) From 8ef5abc8ef270c0220d064c003c6deb4ff8b3a3f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 15:06:44 -0700 Subject: [PATCH 123/154] :( --- .../components/abstraction/abstraction.ml | 129 ++++++++++-------- .../components/abstraction/abstraction.mli | 4 +- plugin/src/core/procedures/search.ml | 4 +- plugin/src/patcher.ml4 | 2 +- 4 files changed, 81 insertions(+), 58 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index 749d22f..f1078a4 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -21,6 +21,7 @@ open Merging open Apputils open Convertibility open Stateutils +open Envutils (* --- TODO for refactoring without breaking things --- *) @@ -31,9 +32,9 @@ open Stateutils * * TODO remove once evar_map refactor is done (needs to be last) *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = +let infer_type (env : env) (evd : evar_map) (trm : types) = let jmt = Typeops.infer env trm in - j_type jmt + evd, j_type jmt (* --- End TODO --- *) @@ -52,15 +53,21 @@ type abstraction_options = * Wrap each candidate in a lambda from anonymous terms with the types of args * Assumes all arguments are bound in env *) -let generalize (env : env) (evd : evar_map) (num_to_abstract : int) (cs : candidates) : candidates = - snd - (List.fold_right - (fun _ (en, l) -> - let typ = unshift (infer_type en evd (mkRel 1)) in - let env_pop = Environ.pop_rel_context 1 en in - (env_pop, List.map (fun b -> mkLambda (Names.Name.Anonymous, typ, b)) l)) - (range 1 (num_to_abstract + 1)) - (env, cs)) +let generalize (env : env) (num_to_abstract : int) (cs : candidates) = + bind + (fold_left_state + (fun (en, l) _ -> + bind + (bind + (fun sigma -> infer_type en sigma (mkRel 1)) + (fun t -> ret (unshift t))) + (fun t -> + let env_pop = Environ.pop_rel_context 1 en in + let l = List.map (fun b -> mkLambda (Names.Name.Anonymous, t, b)) l in + ret (env_pop, l))) + (env, cs) + (List.rev (range 1 (num_to_abstract + 1)))) + (fun p -> ret (snd p)) (* * Get goals for abstraction by a function @@ -106,17 +113,19 @@ let get_concrete_prop (config : abstraction_config) (concrete : closure) : closu (env, p :: (List.tl args)) (* Get the concrete environment and arguments to abstract *) -let get_concrete config strategy evd : closure = +let get_concrete config strategy = let env = config.env in let args = config.args_base in let s = reducer_to_specializer reduce_term in - let evd, base = specialize_using s env config.f_base (Array.of_list args) evd in - let concrete = (env, List.append args [base]) in - match kind_of_abstraction strategy with - | Arguments -> - concrete - | Property -> - get_concrete_prop config concrete + bind + (specialize_using s env config.f_base (Array.of_list args)) + (fun base -> + let concrete = (env, List.append args [base]) in + match kind_of_abstraction strategy with + | Arguments -> + ret concrete + | Property -> + ret (get_concrete_prop config concrete)) (* Get abstract arguments for a function *) let get_abstraction_args config : closure = @@ -126,7 +135,7 @@ let get_abstraction_args config : closure = else match kind g with | Lambda (n, t, b) -> - let en' = push_rel CRD.(LocalAssum(n, t)) en in + let en' = push_local (n, t) en in let (en'', b') = infer_args (i - 1) en' b in (en'', (mkRel i) :: b') | _ -> @@ -135,69 +144,79 @@ let get_abstraction_args config : closure = (* Get the abstract arguments that map to concrete arguments for a particular strategy, function, and arguments *) -let get_abstract config concrete strategy evd : closure = +let get_abstract config concrete strategy = let s = reducer_to_specializer reduce_term in match kind_of_abstraction strategy with | Arguments -> let (env_abs, args_abs) = get_abstraction_args config in let p = shift_by (List.length args_abs) config.f_base in - let evd, base_abs = specialize_using s env_abs p (Array.of_list args_abs) evd in - (env_abs, List.append args_abs [base_abs]) + bind + (specialize_using s env_abs p (Array.of_list args_abs)) + (fun base_abs -> + ret (env_abs, List.append args_abs [base_abs])) | Property -> let args_abs = config.args_base in let (env_p, args_p) = concrete in let p = mkRel (nb_rel env_p) in - let evd, base_abs = specialize_using s env_p p (Array.of_list args_abs) evd in - (env_p, List.append (p :: List.tl args_abs) [base_abs]) + bind + (specialize_using s env_p p (Array.of_list args_abs)) + (fun base_abs -> + ret (env_p, List.append (p :: List.tl args_abs) [base_abs])) (* Given a abstraction strategy, get the abstraction options for the particular function and arguments *) (* TODO num_to_abstract uniformity *) -let get_abstraction_opts config strategy evd : abstraction_options = - let concrete = get_concrete config strategy evd in - let abstract = get_abstract config concrete strategy evd in - match kind_of_abstraction strategy with - | Arguments -> - let goal_type = get_arg_abstract_goal_type config in - let num_to_abstract = List.length config.args_base in - { concrete; abstract; goal_type; num_to_abstract } - | Property -> - let goal_type = get_prop_abstract_goal_type config in - let (env, _) = concrete in - let num_to_abstract = nb_rel env in - { concrete; abstract; goal_type; num_to_abstract } +let get_abstraction_opts config strategy = + bind + (get_concrete config strategy) + (fun concrete -> + bind + (get_abstract config concrete strategy) + (fun abstract -> + match kind_of_abstraction strategy with + | Arguments -> + let goal_type = get_arg_abstract_goal_type config in + let num_to_abstract = List.length config.args_base in + ret { concrete; abstract; goal_type; num_to_abstract } + | Property -> + let goal_type = get_prop_abstract_goal_type config in + let (env, _) = concrete in + let num_to_abstract = nb_rel env in + ret { concrete; abstract; goal_type; num_to_abstract })) (* Abstract candidates with a provided abstraction strategy *) -let abstract_with_strategy (config : abstraction_config) strategy evd : candidates = - let opts = get_abstraction_opts config strategy evd in +let abstract_with_strategy (config : abstraction_config) strategy sigma = + let sigma, opts = get_abstraction_opts config strategy sigma in let (env, args) = opts.concrete in let (env_abs, args_abs) = opts.abstract in - let _, reduced_cs = reduce_all_using strategy env config.cs evd in + let sigma, reduced_cs = reduce_all_using strategy env config.cs sigma in let shift_concrete = List.map (shift_by (nb_rel env_abs - nb_rel env)) in let args_adj = shift_concrete args in let cs_adj = shift_concrete reduced_cs in - let _, bs = substitute_using strategy env_abs args_adj args_abs cs_adj evd in - let lambdas = generalize env_abs evd opts.num_to_abstract bs in + let sigma, bs = substitute_using strategy env_abs args_adj args_abs cs_adj sigma in + let sigma, lambdas = generalize env_abs opts.num_to_abstract bs sigma in Printf.printf "%d abstracted candidates\n" (List.length lambdas); - snd (filter_using strategy env opts.goal_type lambdas evd) + filter_using strategy env opts.goal_type lambdas sigma (* * Try to abstract candidates with an ordered list of abstraction strategies * Return as soon as one is successful * If all fail, return the empty list *) -let abstract_with_strategies (config : abstraction_config) evd : candidates = +let abstract_with_strategies (config : abstraction_config) = let abstract_using = abstract_with_strategy config in let rec try_abstract_using strategies = match strategies with | h :: t -> - let abstracted = abstract_using h evd in - if (List.length abstracted) > 0 then - abstracted - else - try_abstract_using t + bind + (abstract_using h) + (fun abstracted -> + if (List.length abstracted) > 0 then + ret abstracted + else + try_abstract_using t) | _ -> - [] + ret [] in try_abstract_using config.strategies (* @@ -212,8 +231,10 @@ let abstract_with_strategies (config : abstraction_config) evd : candidates = * specialized, so we have nothing to abstract, and we return the original list. * * If the goal types are both specialized, then we abstract. + * + * TODO left off here *) -let try_abstract_inductive evd (d : lift_goal_diff) (cs : candidates) : candidates = +let try_abstract_inductive (d : lift_goal_diff) (cs : candidates) evd : candidates = let goals = goal_types d in let goals_are_apps = fold_tuple (fun t1 t2 -> isApp t1 && isApp t2) goals in if goals_are_apps && non_empty cs then @@ -225,7 +246,7 @@ let try_abstract_inductive evd (d : lift_goal_diff) (cs : candidates) : candidat let num_new_rels = num_new_bindings snd (dest_lift_goals d) in List.map (unshift_local (num_new_rels - 1) num_new_rels) - (abstract_with_strategies config evd) + (snd (abstract_with_strategies config evd)) else give_up else @@ -251,7 +272,7 @@ let abstract_case (opts : options) evd (d : goal_case_diff) cs : candidates = | Kindofchange.FixpointCase ((_, _), cut) when snd (are_cut env cut cs evd) -> cs | _ -> - try_abstract_inductive evd d_goal cs + try_abstract_inductive d_goal cs evd (* * Replace all occurrences of the first term in the second term with Rel 1, diff --git a/plugin/src/core/components/abstraction/abstraction.mli b/plugin/src/core/components/abstraction/abstraction.mli index 20152c3..bad5f35 100644 --- a/plugin/src/core/components/abstraction/abstraction.mli +++ b/plugin/src/core/components/abstraction/abstraction.mli @@ -6,6 +6,7 @@ open Candidates open Abstractionconfig open Proofdiff open Searchopts +open Stateutils (*--- Abstraction ---*) @@ -14,7 +15,8 @@ open Searchopts * Return as soon as one is successful * If all fail, return the empty list *) -val abstract_with_strategies : abstraction_config -> evar_map -> types list +val abstract_with_strategies : + abstraction_config -> evar_map -> candidates state (* * Abstract candidates in a case of an inductive proof. diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index c578882..808d85d 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -52,7 +52,7 @@ let return_patch opts env evd (patches : types list) : types = let specialized_fs_terms = flat_map reconstruct_factors specialized_fs in let generalized = flat_map - (fun ss -> abstract_with_strategies ss evd) + (fun ss -> snd (abstract_with_strategies ss evd)) (snd (configure_fixpoint_cases env (diff_fix_cases env evd (difference old_type new_type no_assumptions)) @@ -62,7 +62,7 @@ let return_patch opts env evd (patches : types list) : types = | ConclusionCase (Some cut) -> let _, patches = reduce_all remove_unused_hypos env evd patches in let evd, strategies = configure_cut_args env cut patches evd in - let generalized = abstract_with_strategies strategies evd in + let generalized = snd (abstract_with_strategies strategies evd) in List.hd generalized (* TODO better failure when none found *) | Hypothesis (_, _) -> let _, patches = reduce_all remove_unused_hypos env evd patches in diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 6244a7e..5047614 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -208,7 +208,7 @@ let abstract n trm goal : unit = let evm, goal_def = intern env evm goal in let goal_type = unwrap_definition env goal_def in let evm, config = configure_from_goal env goal_type c evm in - let abstracted = abstract_with_strategies config evm in + let abstracted = snd (abstract_with_strategies config evm) in if List.length abstracted > 0 then try ignore (define_term n evm (List.hd abstracted) false) From 9b8987d7c480e65587fc004715dc7e99f7d624df Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 18:16:04 -0700 Subject: [PATCH 124/154] Update deps --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 0e53b2d..eb689c9 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 0e53b2d51f253daac8db6fe21b035ea90701db73 +Subproject commit eb689c9eda9c38041fc61fe6361a79a20703bce8 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 3f7201f..c961344 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 3f7201fca529639ea85299e81defae279e387047 +Subproject commit c961344d0cb5b7aa431943d9745a64737dfa84ef diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index f2b83d2..5ba5cd7 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit f2b83d2d354579f088a4e1b0cf1bd0e228991a22 +Subproject commit 5ba5cd79aa3bcdde323a6e7e8f27dccb9055ce26 From c4bd0d7ce7225e652c53f9713b6af493fca7f182 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 18:31:58 -0700 Subject: [PATCH 125/154] abstraction state --- .../components/abstraction/abstraction.ml | 46 +++++++++++-------- .../components/abstraction/abstraction.mli | 3 +- .../differencing/inddifferencers.ml | 2 +- 3 files changed, 31 insertions(+), 20 deletions(-) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index f1078a4..e2d8968 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -231,26 +231,36 @@ let abstract_with_strategies (config : abstraction_config) = * specialized, so we have nothing to abstract, and we return the original list. * * If the goal types are both specialized, then we abstract. - * - * TODO left off here *) -let try_abstract_inductive (d : lift_goal_diff) (cs : candidates) evd : candidates = +let try_abstract_inductive (d : lift_goal_diff) (cs : candidates) = let goals = goal_types d in let goals_are_apps = fold_tuple (fun t1 t2 -> isApp t1 && isApp t2) goals in if goals_are_apps && non_empty cs then let (env, d_type, cs) = merge_lift_diff_envs d cs in let new_goal_type = new_proof d_type in let old_goal_type = old_proof d_type in - if List.for_all2 (fun t1 t2 -> snd (convertible env evd t1 t2)) (unfold_args old_goal_type) (unfold_args new_goal_type) then - let _, config = configure_args env d_type cs evd in - let num_new_rels = num_new_bindings snd (dest_lift_goals d) in - List.map - (unshift_local (num_new_rels - 1) num_new_rels) - (snd (abstract_with_strategies config evd)) - else - give_up + branch_state + (fun env -> + forall_state + (fun (t1, t2) sigma -> convertible env sigma t1 t2) + (List.map2 + (fun t1 t2 -> (t1, t2)) + (unfold_args old_goal_type) + (unfold_args new_goal_type))) + (fun env -> + bind + (configure_args env d_type cs) + (fun config -> + let num_new_rels = num_new_bindings snd (dest_lift_goals d) in + bind + (abstract_with_strategies config) + (map_state + (fun t -> + ret (unshift_local (num_new_rels - 1) num_new_rels t))))) + (fun _ -> ret give_up) + env else - cs + ret cs (* * Abstract candidates in a case of an inductive proof. @@ -259,20 +269,20 @@ let try_abstract_inductive (d : lift_goal_diff) (cs : candidates) evd : candidat * If there is nothing to abstract or if we cannot determine what to * abstract, then return the original list. *) -let abstract_case (opts : options) evd (d : goal_case_diff) cs : candidates = +let abstract_case (opts : options) (d : goal_case_diff) cs sigma = let d_goal = erase_proofs d in let old_goal = old_proof d_goal in let env = context_env old_goal in match get_change opts with | Kindofchange.Hypothesis (_, _) -> let (g_o, g_n) = map_tuple context_term (old_goal, new_proof d_goal) in - snd (filter_by_type (mkProd (Names.Name.Anonymous, g_n, shift g_o)) env evd cs) + filter_by_type (mkProd (Names.Name.Anonymous, g_n, shift g_o)) env sigma cs | Kindofchange.InductiveType (_, _) -> - cs - | Kindofchange.FixpointCase ((_, _), cut) when snd (are_cut env cut cs evd) -> - cs + sigma, cs + | Kindofchange.FixpointCase ((_, _), cut) -> + branch_state (are_cut env cut) ret (try_abstract_inductive d_goal) cs sigma | _ -> - try_abstract_inductive d_goal cs evd + try_abstract_inductive d_goal cs sigma (* * Replace all occurrences of the first term in the second term with Rel 1, diff --git a/plugin/src/core/components/abstraction/abstraction.mli b/plugin/src/core/components/abstraction/abstraction.mli index bad5f35..8ef6ef4 100644 --- a/plugin/src/core/components/abstraction/abstraction.mli +++ b/plugin/src/core/components/abstraction/abstraction.mli @@ -25,7 +25,8 @@ val abstract_with_strategies : * If there is nothing to abstract or if we cannot determine what to * abstract, then return the original list. *) -val abstract_case : (evar_map -> goal_case_diff -> candidates -> candidates) configurable +val abstract_case : + (goal_case_diff -> candidates -> evar_map -> candidates state) configurable (* * Replace all occurrences of the first term in the second term with Rel 1, diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 423d193..53fc193 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -67,7 +67,7 @@ let rec diff_case abstract diff evd (d : goal_case_diff) : candidates = * principle for the constructor version to get a more general patch. *) let diff_ind_case opts evd diff (d : goal_case_diff) : candidates = - diff_case (abstract_case opts evd d) diff evd d + diff_case (fun c -> snd (abstract_case opts d c evd)) diff evd d (* * Search a case of a difference in proof categories. From 1a6b34262517faf524effa8dfcfeb19317707358 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 18:52:23 -0700 Subject: [PATCH 126/154] state in factoring --- .../core/components/factoring/factoring.ml | 111 ++++++++++-------- .../core/components/factoring/factoring.mli | 5 +- .../core/components/inversion/inverting.ml | 4 +- plugin/src/core/procedures/search.ml | 2 +- plugin/src/patcher.ml4 | 2 +- 5 files changed, 69 insertions(+), 55 deletions(-) diff --git a/plugin/src/core/components/factoring/factoring.ml b/plugin/src/core/components/factoring/factoring.ml index de8e5b2..b8bc2c0 100644 --- a/plugin/src/core/components/factoring/factoring.ml +++ b/plugin/src/core/components/factoring/factoring.ml @@ -11,11 +11,12 @@ open Debruijn open Reducers open Contextutils open Convertibility +open Stateutils +open Zooming +open Envutils type factors = (env * types) list -open Zooming - (* --- Assumptions for path finding --- *) let assumption : types = mkRel 1 @@ -32,15 +33,15 @@ let apply_assumption (fs : factors) (trm : types) : types = (* * Check if the term is the assumption (last term in the environment) *) -let is_assumption (env : env) (evd : evar_map) (trm : types) : bool = - snd (convertible env evd trm assumption) +let is_assumption (env : env) (trm : types) sigma = + convertible env sigma trm assumption (* * Assume a term of type typ in an environment *) let assume (env : env) (n : Name.t) (typ : types) : env = let env_pop = pop_rel_context 1 env in - push_rel CRD.(LocalAssum(n, typ)) env_pop + push_local (n, typ) env_pop (* --- Path-finding auxiliary functionality --- *) @@ -76,31 +77,38 @@ let assume (env : env) (n : Name.t) (typ : types) : env = * fail for inveresion, but we might want it if we use factoring for other * purposes, like to simplify abstraction. *) -let rec find_path (env : env) (evd : evar_map) (trm : types) : factors = - if is_assumption env evd trm then - [(env, trm)] - else - match kind trm with - | App (f, args) -> - let paths = Array.map (find_path env evd) args in - let nonempty_paths = List.filter non_empty (Array.to_list paths) in - if List.length nonempty_paths > 1 then - [(env, trm)] - else if List.length nonempty_paths = 1 then - let path = List.hd nonempty_paths in - let (env_arg, arg) = List.hd path in - let assume_arg i a = apply_assumption (Array.get paths i) a in - let args_assumed = Array.mapi assume_arg args in - try - let evd, arg_typ = reduce_type env_arg evd arg in - let t = unshift arg_typ in - (assume env Anonymous t, mkApp (f, args_assumed)) :: path - with _ -> - [] - else - [] - | _ -> (* other terms not yet implemented *) - [] +let rec find_path (env : env) (trm : types) = + branch_state + (fun (env, trm) -> is_assumption env trm) + (fun (env, trm) -> ret [(env, trm)]) + (fun (env, trm) -> + match kind trm with + | App (f, args) -> + bind + (map_state_array (find_path env) args) + (fun paths -> + let nonempty_paths = List.filter non_empty (Array.to_list paths) in + if List.length nonempty_paths > 1 then + ret [(env, trm)] + else if List.length nonempty_paths = 1 then + let path = List.hd nonempty_paths in + let (env_arg, arg) = List.hd path in + let assume_arg i a = apply_assumption (Array.get paths i) a in + let args_assumed = Array.mapi assume_arg args in + try + bind + (fun sigma -> reduce_type env_arg sigma arg) + (fun arg_typ -> + let t = unshift arg_typ in + let env_t = assume env Anonymous t in + ret ((env_t, mkApp (f, args_assumed)) :: path)) + with _ -> + ret [] + else + ret []) + | _ -> (* other terms not yet implemented *) + ret []) + (env, trm) (* --- Top-level factoring --- *) @@ -112,17 +120,22 @@ let rec find_path (env : env) (evd : evar_map) (trm : types) : factors = * First zoom in all the way, then use the auxiliary path-finding * function. *) -let factor_term (env : env) (evd : evar_map) (trm : types) : factors = - let (env_zoomed, trm_zoomed) = zoom_lambda_term env (snd (reduce_term env evd trm)) in - let path_body = find_path env_zoomed evd trm_zoomed in - List.map - (fun (env, body) -> - if is_assumption env evd body then - (env, body) - else - let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in - (pop_rel_context 1 env, mkLambda (n, t, body))) - path_body +let factor_term (env : env) (trm : types) = + bind + (fun sigma -> reduce_term env sigma trm) + (fun trm -> + let (env_zoomed, trm_zoomed) = zoom_lambda_term env trm in + bind + (find_path env_zoomed trm_zoomed) + (map_state + (fun (env, body) -> + branch_state + (is_assumption env) + (fun body -> ret (env, body)) + (fun body -> + let (n, _, t) = CRD.to_tuple @@ lookup_rel 1 env in + ret (pop_rel_context 1 env, mkLambda (n, t, body))) + body))) (* --- Using factors --- *) @@ -139,13 +152,13 @@ let reconstruct_factors (fs : factors) : types list = (List.tl (List.rev fs)) (* Apply factors to reconstruct a single term *) -let apply_factors evd (fs : factors) : types = +let apply_factors (fs : factors) = let (env, base) = List.hd fs in - let body = - List.fold_right - (fun (en, t) t_app -> - snd (specialize_using specialize_no_reduce en (shift t) (Array.make 1 t_app) evd)) - (List.tl fs) - base - in reconstruct_lambda env body + let specialize = specialize_using specialize_no_reduce in + bind + (fold_left_state + (fun t_app (env, t) -> specialize env (shift t) (Array.make 1 t_app)) + base + (List.rev (List.tl fs))) + (fun body -> ret (reconstruct_lambda env body)) diff --git a/plugin/src/core/components/factoring/factoring.mli b/plugin/src/core/components/factoring/factoring.mli index 1cf2e98..f32c743 100644 --- a/plugin/src/core/components/factoring/factoring.mli +++ b/plugin/src/core/components/factoring/factoring.mli @@ -3,6 +3,7 @@ open Constr open Environ open Evd +open Stateutils (* * Factors are a list of environment-type pairs, where the environment @@ -22,7 +23,7 @@ type factors = (env * types) list * X -> Z, find factors through which it passes * (e.g., [H : X, F : X -> Y, G : Y -> Z] where trm = G o F) *) -val factor_term : env -> evar_map -> types -> factors +val factor_term : env -> types -> evar_map -> factors state (* * Reconstruct factors as a user-friendly list of terms @@ -32,4 +33,4 @@ val reconstruct_factors : factors -> types list (* * Apply factors to reconstruct a single term *) -val apply_factors : evar_map -> factors -> types +val apply_factors : factors -> evar_map -> types state diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 1d71434..da27f54 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -185,10 +185,10 @@ let invert_factor evd (env, rp) : (env * types) option = * Use the supplied inverter to handle factors *) let invert_using (invert : inverter) env evd (trm : types) : types option = - let fs = factor_term env evd trm in + let fs = snd (factor_term env trm evd) in let inv_fs = invert_factors evd invert fs in if List.length inv_fs > 0 then - Some (apply_factors evd inv_fs) + Some (snd (apply_factors inv_fs evd)) else None diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index 808d85d..c87b11b 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -48,7 +48,7 @@ let return_patch opts env evd (patches : types list) : types = let reduction_condition en evd tr = has_cut_type_strict_sym en cut tr evd in let reducer = reduce_body_if reduction_condition body_reducer in let _, specialized = reduce_all reducer env evd patches in - let specialized_fs = List.map (factor_term env evd) specialized in + let specialized_fs = List.map (fun t -> snd (factor_term env t evd)) specialized in let specialized_fs_terms = flat_map reconstruct_factors specialized_fs in let generalized = flat_map diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 5047614..be039dc 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -229,7 +229,7 @@ let factor n trm : unit = let (evm, env) = Pfedit.get_current_context() in let evm, def = intern env evm trm in let body = lookup_definition env def in - let fs = reconstruct_factors (factor_term env evm body) in + let fs = reconstruct_factors (snd (factor_term env body evm)) in let prefix = Id.to_string n in try List.iteri From 9330a7c38039fc91f0482c5a509ddf4e5f6ad114 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Tue, 3 Sep 2019 20:03:48 -0700 Subject: [PATCH 127/154] state in inversion --- .../core/components/inversion/inverting.ml | 223 +++++++++++------- .../core/components/inversion/inverting.mli | 4 +- plugin/src/core/procedures/search.ml | 2 +- plugin/src/patcher.ml4 | 2 +- plugin/src/representation/assumptions.ml | 4 +- plugin/src/representation/assumptions.mli | 6 +- 6 files changed, 145 insertions(+), 96 deletions(-) diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index da27f54..9ad2a88 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -16,8 +16,9 @@ open Contextutils open Equtils open Convertibility open Stateutils +open Envutils -type inverter = evar_map -> (env * types) -> (env * types) option +type inverter = (env * types) -> evar_map -> ((env * types) option) state (* --- TODO for refactoring without breaking things --- *) @@ -25,10 +26,12 @@ type inverter = evar_map -> (env * types) -> (env * types) option * Infer the type of trm in env * Note: This does not yet use good evar map hygeine; will fix that * during the refactor. + * + * TODO port this one last *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = +let infer_type (env : env) (sigma : evar_map) (trm : types) = let jmt = Typeops.infer env trm in - j_type jmt + sigma, j_type jmt (* --- End TODO --- *) @@ -42,22 +45,24 @@ let infer_type (env : env) (evd : evar_map) (trm : types) : types = * * If inverting any term along the way fails, produce the empty list. *) -let invert_factors evd (invert : inverter) (fs : factors) : factors = +let invert_factors (invert : inverter) (fs : factors) = let get_all_or_none (l : 'a option list) : 'a list = if List.for_all Option.has_some l then List.map Option.get l else [] in - let inverse_options = List.map (invert evd) fs in - let inverted = List.rev (get_all_or_none inverse_options) in - match inverted with (* swap final hypothesis *) - | (env_inv, trm_inv) :: t when List.length t > 0 -> - let (n, h_inv, _) = destLambda (snd (last t)) in - let env_inv = push_rel CRD.(LocalAssum(n, h_inv)) (pop_rel_context 1 env_inv) in - (env_inv, trm_inv) :: t - | _ -> - inverted + bind + (map_state invert fs) + (fun inverse_options -> + let inverted = List.rev (get_all_or_none inverse_options) in + match inverted with (* swap final hypothesis *) + | (env_inv, trm_inv) :: t when List.length t > 0 -> + let (n, h_inv, _) = destLambda (snd (last t)) in + let env_inv = push_local (n, h_inv) (pop_rel_context 1 env_inv) in + ret ((env_inv, trm_inv) :: t) + | _ -> + ret inverted) (* --- Invert a term --- *) @@ -69,23 +74,38 @@ let invert_factors evd (invert : inverter) (fs : factors) : factors = * arguments * Especially since rels will go negative *) -let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_map = - let rec build_swaps i swap = +let build_swap_map (env : env) (o : types) (n : types) = + let rec build_swaps i swap : evar_map -> swap_map state = match map_tuple kind swap with | (App (f_s, args_s), App (f_n, args_n)) -> - let is_swap s evd = evd, not (fold_tuple equal s) in - let _, arg_swaps = filter_swaps is_swap (of_arguments args_s args_n) evd in - let swaps = unshift_swaps_by i arg_swaps in - merge_swaps (swaps :: (map_swaps (build_swaps i) swaps)) + let is_swap s = ret (not (fold_tuple equal s)) in + bind + (filter_swaps is_swap (of_arguments args_s args_n)) + (fun arg_swaps -> + let swaps_hd = unshift_swaps_by i arg_swaps in + bind + (map_swaps (build_swaps i) swaps_hd) + (fun swaps_tl -> + ret (merge_swaps (swaps_hd :: swaps_tl)))) | (Lambda (n_s, t_s, b_s), Lambda (_, t_n, b_n)) -> - let t_swaps = build_swaps i (t_s, t_n) in - let b_swaps = build_swaps (i + 1) (b_s, b_n) in - merge_swaps (t_swaps :: [b_swaps]) + bind + (build_swaps i (t_s, t_n)) + (fun t_swaps -> + bind + (build_swaps (i + 1) (b_s, b_n)) + (fun b_swaps -> + ret (merge_swaps (t_swaps :: [b_swaps])))) | (_, _) -> - no_swaps + ret no_swaps in - let _, srcs = filter_state (fun n evd -> convertible env evd o n) (snd (all_typ_swaps_combs env n evd)) evd in - merge_swaps (List.map (fun s -> build_swaps 0 (s, n)) srcs) + bind + (bind + (all_typ_swaps_combs env n) + (filter_state (fun n sigma -> convertible env sigma o n))) + (fun srcs -> + bind + (map_state (fun s -> build_swaps 0 (s, n)) srcs) + (fun swaps -> ret (merge_swaps swaps))) (* * Before swapping arguments, try exploiting symmetry of a type like equality @@ -96,38 +116,53 @@ let build_swap_map (env : env) (evd : evar_map) (o : types) (n : types) : swap_m * Generalizing how to swap arguments is hard and will still probably involve * swaps above. *) -let exploit_type_symmetry (env : env) (evd : evar_map) (trm : types) : types list = - snd - (map_subterms_env_if_lazy - (fun _ evd _ t -> evd, isApp t && is_rewrite (fst (destApp t))) - (fun en evd _ t -> - let (f, args) = destApp t in - let i_eq = Array.length args - 1 in - let eq = args.(i_eq) in - let eq_type = infer_type en evd eq in - let eq_args = List.append (Array.to_list (snd (destApp eq_type))) [eq] in - let eq_r = mkApp (eq_sym, Array.of_list eq_args) in - let i_src = 1 in - let i_dst = 4 in - let args_r = - Array.mapi - (fun i a -> - if i = i_eq then - eq_r - else if i = i_src then - args.(i_dst) - else if i = i_dst then - args.(i_src) - else - a) - args - in evd, [mkApp (f, args_r)]) - id - env - evd - () - trm) +let exploit_type_symmetry (env : env) (trm : types) sigma = + map_subterms_env_if_lazy + (fun _ sigma _ t -> sigma, isApp t && is_rewrite (fst (destApp t))) + (fun en sigma _ t -> + let (f, args) = destApp t in + let i_eq = Array.length args - 1 in + let eq = args.(i_eq) in + let sigma, eq_type = infer_type en sigma eq in + let eq_args = List.append (Array.to_list (snd (destApp eq_type))) [eq] in + let eq_r = mkApp (eq_sym, Array.of_list eq_args) in + let i_src = 1 in + let i_dst = 4 in + let args_r = + Array.mapi + (fun i a -> + if i = i_eq then + eq_r + else if i = i_src then + args.(i_dst) + else if i = i_dst then + args.(i_src) + else + a) + args + in sigma, [mkApp (f, args_r)]) + id + env + sigma + () + trm + +(* + * Same as above, but filter to the goal type + *) +let exploit_type_symmetry_goal env trm goal_type = + bind + (exploit_type_symmetry env trm) + (fun flipped sigma -> filter_by_type goal_type env sigma flipped) +(* + * Apply a swap map, and then filter to the goal type + *) +let apply_swaps_goal env trm goal_type swap_map = + bind + (all_conv_swaps_combs env swap_map trm) + (fun swapped sigma -> filter_by_type goal_type env sigma swapped) + (* * Try to exploit symmetry and invert a single factor (like a single * rewrite) so that it goes from old -> new instead of new -> old. @@ -155,49 +190,57 @@ let exploit_type_symmetry (env : env) (evd : evar_map) (trm : types) : types lis * and will increase candidates significantly, so for now we leave it * as a separate step. *) -let invert_factor evd (env, rp) : (env * types) option = - let _, rp = reduce_term env evd rp in - match kind rp with - | Lambda (n, old_goal_type, body) -> - let env_body = push_rel CRD.(LocalAssum(n, old_goal_type)) env in - let evd, body_type = reduce_type env_body evd body in - let new_goal_type = unshift body_type in - let rp_goal = snd (all_conv_substs env evd (old_goal_type, new_goal_type) rp) in (* TODO evar_map *) - let goal_type = mkProd (n, new_goal_type, shift old_goal_type) in - let flipped = exploit_type_symmetry env evd rp_goal in - let _, flipped_wt = filter_by_type goal_type env evd flipped in - if List.length flipped_wt > 0 then - Some (env, List.hd flipped_wt) - else - let swap_map = build_swap_map env evd old_goal_type new_goal_type in - let _, swapped = all_conv_swaps_combs env swap_map rp_goal evd in - let _, swapped_wt = filter_by_type goal_type env evd swapped in - if List.length swapped_wt > 0 then - Some (env, List.hd swapped_wt) - else - None - | _ -> - Some (env, rp) +let invert_factor (env, rp) = + bind + (fun sigma -> reduce_term env sigma rp) + (fun rp sigma -> + match kind rp with + | Lambda (n, old_goal_type, body) -> + let env_body = push_local (n, old_goal_type) env in + let sigma, body_type = reduce_type env_body sigma body in + let new_goal_type = unshift body_type in + let sigma, rp_goal = all_conv_substs env sigma (old_goal_type, new_goal_type) rp in + let goal_type = mkProd (n, new_goal_type, shift old_goal_type) in + bind + (exploit_type_symmetry_goal env rp_goal goal_type) + (fun flipped_wt -> + if List.length flipped_wt > 0 then + ret (Some (env, List.hd flipped_wt)) + else + bind + (bind + (build_swap_map env old_goal_type new_goal_type) + (apply_swaps_goal env rp_goal goal_type)) + (fun swapped_wt -> + if List.length swapped_wt > 0 then + ret (Some (env, List.hd swapped_wt)) + else + ret None)) + sigma + | _ -> + sigma, (Some (env, rp))) (* * Invert a term in an environment * Recursively invert function composition * Use the supplied inverter to handle factors *) -let invert_using (invert : inverter) env evd (trm : types) : types option = - let fs = snd (factor_term env trm evd) in - let inv_fs = invert_factors evd invert fs in - if List.length inv_fs > 0 then - Some (snd (apply_factors inv_fs evd)) - else - None +let invert_using (invert : inverter) env (trm : types) = + bind + (bind (factor_term env trm) (invert_factors invert)) + (fun inv_fs -> + if List.length inv_fs > 0 then + bind (apply_factors inv_fs) (fun app -> ret (Some app)) + else + ret None) (* * Try to invert a list of terms in an environment * Recursively invert function composition * Use the supplied inverter to handle low-level inverses *) -let invert_terms invert env evd (ps : types list) : types list = - List.map - Option.get - (List.filter Option.has_some (List.map (invert_using invert env evd) ps)) +let invert_terms invert env (ps : types list) = + bind + (map_state (invert_using invert env) ps) + (fun inverted_opts -> + ret (List.map Option.get (List.filter Option.has_some inverted_opts))) diff --git a/plugin/src/core/components/inversion/inverting.mli b/plugin/src/core/components/inversion/inverting.mli index cbb8468..e9755f6 100644 --- a/plugin/src/core/components/inversion/inverting.mli +++ b/plugin/src/core/components/inversion/inverting.mli @@ -3,6 +3,7 @@ open Constr open Environ open Evd +open Stateutils type inverter @@ -18,4 +19,5 @@ val invert_factor : inverter * Recursively invert function composition * Use the supplied inverter to handle low-level inverses *) -val invert_terms : inverter -> env -> evar_map -> types list -> types list +val invert_terms : + inverter -> env -> types list -> evar_map -> (types list) state diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index c87b11b..e86192c 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -92,7 +92,7 @@ let search_for_patch evd (default : types) (opts : options) (d : goal_proof_diff let rev_patches = diff (reverse d) in Printf.printf "%s\n" "searched backwards"; Printf.printf "inverting %d candidates\n" (List.length rev_patches); - let inverted = invert_terms invert_factor env evd rev_patches in + let inverted = snd (invert_terms invert_factor env rev_patches evd) in if non_empty inverted then return_patch opts env evd inverted else diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index be039dc..8a6110a 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -98,7 +98,7 @@ let configure_optimize trm : goal_proof_diff * options = (* Common inversion functionality *) let invert_patch n env evm patch = - let inverted = invert_terms invert_factor env evm [patch] in + let evm, inverted = invert_terms invert_factor env [patch] evm in try let patch_inv = List.hd inverted in let _ = infer_type env evm patch_inv in diff --git a/plugin/src/representation/assumptions.ml b/plugin/src/representation/assumptions.ml index 09640ad..66a55cd 100644 --- a/plugin/src/representation/assumptions.ml +++ b/plugin/src/representation/assumptions.ml @@ -253,8 +253,8 @@ let combinations_of_arguments (args : types array) : swap_map = (* * Map a function on two types along a swap map and return a list *) -let map_swaps f (s : swap_map) : 'a list = - List.map f s +let map_swaps f (s : swap_map) = + map_state f s (* * Flatten a list of swap maps into one swap map with no duplicates diff --git a/plugin/src/representation/assumptions.mli b/plugin/src/representation/assumptions.mli index 8cb30fe..a6bda0e 100644 --- a/plugin/src/representation/assumptions.mli +++ b/plugin/src/representation/assumptions.mli @@ -166,7 +166,11 @@ val filter_swaps : (* * Map a function on two types along a swap map and return a list *) -val map_swaps : ((types * types) -> 'a) -> swap_map -> 'a list +val map_swaps : + ((types * types) -> evar_map -> 'a state) -> + swap_map -> + evar_map -> + ('a list) state (* * Flatten a list of swap maps into one swap map with no duplicates From 361df7ba30c3a32940aa02f3a675715787c4f1f5 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 13:50:22 -0700 Subject: [PATCH 128/154] Update lib to have new stateutils functions --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index eb689c9..50d51ba 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit eb689c9eda9c38041fc61fe6361a79a20703bce8 +Subproject commit 50d51baff9af7e37e86e5973baf3ebcbccc6de41 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index c961344..044097e 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit c961344d0cb5b7aa431943d9745a64737dfa84ef +Subproject commit 044097e25a7a78269cd0aebdf787a43ed6775452 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 5ba5cd7..bb2cc98 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 5ba5cd79aa3bcdde323a6e7e8f27dccb9055ce26 +Subproject commit bb2cc9899287006d225e2e0c857cecf89602ea10 From 8e1b61f3dc44c23d15dab63c3741274d3231a95f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 14:02:10 -0700 Subject: [PATCH 129/154] Rename function in lib --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index 50d51ba..f9459b5 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit 50d51baff9af7e37e86e5973baf3ebcbccc6de41 +Subproject commit f9459b54e937d4b83fc2800c6c680b880c10e962 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 044097e..f8767f4 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 044097e25a7a78269cd0aebdf787a43ed6775452 +Subproject commit f8767f495b3695cd08513483a2403236ad8e1ca8 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index bb2cc98..b01f79e 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit bb2cc9899287006d225e2e0c857cecf89602ea10 +Subproject commit b01f79e46c313f836e4764ce249ebb7377c0eb9a From 30e27fcb12efcd4ae328b1a3912a5e2a544f223e Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 14:42:49 -0700 Subject: [PATCH 130/154] add many more useful stateutils --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index f9459b5..f2e37b1 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit f9459b54e937d4b83fc2800c6c680b880c10e962 +Subproject commit f2e37b1c13321937d5410ba7cd75ed0d9cc22cc2 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index f8767f4..3b757ee 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit f8767f495b3695cd08513483a2403236ad8e1ca8 +Subproject commit 3b757eea2d94c8d2f13823a4108caeba871f01c1 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index b01f79e..2249871 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit b01f79e46c313f836e4764ce249ebb7377c0eb9a +Subproject commit 2249871ed38e53e3a83763238a5c85a146e87b66 From 61f7c8f1a07a65e5a540edccc130e1074452383a Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 14:58:46 -0700 Subject: [PATCH 131/154] change detectors with state --- .../differencing/changedetectors.ml | 94 ++++++++++++------- .../differencing/changedetectors.mli | 2 +- .../components/differencing/differencers.ml | 7 +- .../components/differencing/differencers.mli | 7 +- plugin/src/patcher.ml4 | 2 +- 5 files changed, 71 insertions(+), 41 deletions(-) diff --git a/plugin/src/core/components/differencing/changedetectors.ml b/plugin/src/core/components/differencing/changedetectors.ml index 7635eac..b0a0212 100644 --- a/plugin/src/core/components/differencing/changedetectors.ml +++ b/plugin/src/core/components/differencing/changedetectors.ml @@ -12,6 +12,8 @@ open Utilities open Zooming open Contextutils open Convertibility +open Stateutils +open Envutils (* * If the kind of change is a change in conclusion, then @@ -52,50 +54,72 @@ let find_kind_of_conclusion cut (d : goal_proof_diff) = * * Otherwise, search for a change in conclusion. *) -let find_kind_of_change evd (cut : cut_lemma option) (d : goal_proof_diff) = +let find_kind_of_change (cut : cut_lemma option) (d : goal_proof_diff) = let d_goals = erase_proofs d in - let goals = goal_types d_goals in let env = context_env (old_proof d_goals) in - let r = reduce_remove_identities env evd in - let _, old_goal = r (fst goals) in - let _, new_goal = r (snd goals) in + let r t sigma = reduce_remove_identities env sigma t in + let not_convertible = + not_state (fun (t_o, t_n) sigma -> convertible env sigma t_o t_n) + in + let all_convertible = + fold_tuple_state + (forall2_state (fun t1 t2 sigma -> convertible env sigma t1 t2)) + in let rec diff env typ_o typ_n = match map_tuple kind (typ_o, typ_n) with | (Prod (n_o, t_o, b_o), Prod (_, t_n, b_n)) -> - if (not (snd (convertible env evd t_o t_n))) then - let d_typs = difference t_o t_n no_assumptions in - if same_shape env d_typs then - InductiveType (t_o, t_n) - else - let (t_o', t_n') = map_tuple (reconstruct_product env) (t_o, t_n) in - Hypothesis (t_o', t_n') - else - diff (push_rel CRD.(LocalAssum(n_o, t_o)) env) b_o b_n + branch_state + not_convertible + (fun (t_o, t_n) -> + let d_typs = difference t_o t_n no_assumptions in + if same_shape env d_typs then + ret (InductiveType (t_o, t_n)) + else + let (t_o, t_n) = map_tuple (reconstruct_product env) (t_o, t_n) in + ret (Hypothesis (t_o, t_n))) + (fun (t_o, t_n) -> + diff (push_local (n_o, t_o) env) b_o b_n) + (t_o, t_n) | (App (f_o, args_o), App (f_n, args_n)) -> if (not (Array.length args_o = Array.length args_n)) then - Conclusion + ret Conclusion else let args_o = Array.to_list args_o in let args_n = Array.to_list args_n in - if isConst f_o && isConst f_n && (not (snd (convertible env evd f_o f_n))) then - if List.for_all2 (fun t1 t2 -> snd (convertible env evd t1 t2)) args_o args_n then - if not (Option.has_some cut) then - failwith "Must supply cut lemma for change in fixpoint" - else - FixpointCase ((f_o, f_n), Option.get cut) - else - Conclusion - else - let arg_confs = List.map2 (diff env) args_o args_n in - if List.for_all is_conclusion arg_confs then - Conclusion - else - List.find (fun change -> not (is_conclusion change)) arg_confs + branch_state + (and_state_fold + (fun (f_o, f_n) -> ret (isConst f_o && isConst f_n)) + not_convertible) + (fun (f_o, f_n) -> + branch_state + all_convertible + (fun _ -> + if not (Option.has_some cut) then + failwith "Must supply cut lemma for change in fixpoint" + else + ret (FixpointCase ((f_o, f_n), Option.get cut))) + (fun _ -> + ret Conclusion) + (args_o, args_n)) + (fun (f_o, f_n) -> + bind + (map2_state (diff env) args_o args_n) + (fun confs -> + if List.for_all is_conclusion confs then + ret Conclusion + else + ret (List.find (fun ch -> not (is_conclusion ch)) confs))) + (f_o, f_n) | _ -> - Conclusion + ret Conclusion in - let change = diff env old_goal new_goal in - if is_conclusion change then - find_kind_of_conclusion cut d - else - change + bind + (map_tuple_state r (goal_types d_goals)) + (fun (old_goal, new_goal) -> + bind + (diff env old_goal new_goal) + (fun change -> + if is_conclusion change then + ret (find_kind_of_conclusion cut d) + else + ret change)) diff --git a/plugin/src/core/components/differencing/changedetectors.mli b/plugin/src/core/components/differencing/changedetectors.mli index f365258..e3ea072 100644 --- a/plugin/src/core/components/differencing/changedetectors.mli +++ b/plugin/src/core/components/differencing/changedetectors.mli @@ -8,4 +8,4 @@ open Differencers * Given a difference in proofs with goals and an optional lemma to cut by, * determine what has changed about the proof *) -val find_kind_of_change : evar_map -> cut_lemma option -> proof_change_detector +val find_kind_of_change : cut_lemma option -> proof_change_detector diff --git a/plugin/src/core/components/differencing/differencers.ml b/plugin/src/core/components/differencing/differencers.ml index c73501d..9f896b4 100644 --- a/plugin/src/core/components/differencing/differencers.ml +++ b/plugin/src/core/components/differencing/differencers.ml @@ -5,8 +5,11 @@ open Proofdiff open Candidates open Proofcat open Kindofchange +open Evd +open Stateutils -type ('a, 'b) differencer = 'a proof_diff -> 'b +type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove later *) +type ('a, 'b) differencer_todo = 'a proof_diff -> evar_map -> 'b state type 'a candidate_differencer = ('a, candidates) differencer type proof_differencer = (context_object * proof_cat) candidate_differencer @@ -17,7 +20,7 @@ type arr_differencer = (types array) candidate_differencer type 'a candidate_list_differencer = ('a, candidates list) differencer type arr_list_differencer = (types array) candidate_list_differencer -type 'a change_detector = ('a, kind_of_change) differencer +type 'a change_detector = ('a, kind_of_change) differencer_todo type proof_change_detector = (context_object * proof_cat) change_detector type 'a predicate_differencer = ('a, bool) differencer diff --git a/plugin/src/core/components/differencing/differencers.mli b/plugin/src/core/components/differencing/differencers.mli index 807fcf5..07576de 100644 --- a/plugin/src/core/components/differencing/differencers.mli +++ b/plugin/src/core/components/differencing/differencers.mli @@ -5,8 +5,11 @@ open Proofdiff open Candidates open Proofcat open Kindofchange +open Evd +open Stateutils -type ('a, 'b) differencer = 'a proof_diff -> 'b +type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove when done *) +type ('a, 'b) differencer_todo = 'a proof_diff -> evar_map -> 'b state type 'a candidate_differencer = ('a, candidates) differencer type proof_differencer = (context_object * proof_cat) candidate_differencer @@ -17,7 +20,7 @@ type arr_differencer = (types array) candidate_differencer type 'a candidate_list_differencer = ('a, candidates list) differencer type arr_list_differencer = (types array) candidate_list_differencer -type 'a change_detector = ('a, kind_of_change) differencer +type 'a change_detector = ('a, kind_of_change) differencer_todo type proof_change_detector = (context_object * proof_cat) change_detector type 'a predicate_differencer = ('a, bool) differencer diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 8a6110a..a3412cc 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -85,7 +85,7 @@ let configure trm1 trm2 cut : goal_proof_diff * options = let _, c1 = eval_proof env trm1 Evd.empty in let _, c2 = eval_proof env trm2 Evd.empty in let d = add_goals (difference c1 c2 no_assumptions) in - let change = find_kind_of_change evm lemma d in + let _, change = find_kind_of_change lemma d evm in (d, configure_search d change lemma) (* Initialize diff & search configuration for optimization *) From 1c2edd18d75cff2d8d54f2985ddc123962c8390f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 17:22:47 -0700 Subject: [PATCH 132/154] buggy attempt at starting state in differencing --- .../differencing/appdifferencers.ml | 63 ++++---- .../differencing/appdifferencers.mli | 6 +- .../components/differencing/differencers.ml | 6 +- .../components/differencing/differencers.mli | 4 +- .../components/differencing/differencing.ml | 32 ++-- .../components/differencing/differencing.mli | 2 +- .../differencing/fixdifferencers.ml | 12 +- .../differencing/fixdifferencers.mli | 2 +- .../differencing/higherdifferencers.ml | 22 +-- .../differencing/higherdifferencers.mli | 3 +- .../differencing/inddifferencers.ml | 45 +++--- .../differencing/inddifferencers.mli | 4 +- .../differencing/proofdifferencers.ml | 148 +++++++++++------- .../differencing/proofdifferencers.mli | 4 +- plugin/src/core/procedures/search.ml | 8 +- 15 files changed, 195 insertions(+), 166 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 129aa19..5e2028e 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -16,6 +16,7 @@ open Zooming open Catzooming open Debruijn open Filters +open Stateutils (* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) @@ -63,34 +64,34 @@ let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible en * * TODO: clean up *) -let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candidates = +let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : Differencers.proof_differencer configurable) opts (d : goal_proof_diff) evd = let (_, env) = fst (old_proof (dest_goals d)) in match map_tuple kind (proof_terms d) with | (App (f_o, args_o), App (f_n, args_n)) when Array.length args_o = Array.length args_n -> - let diff_rec diff opts = diff_terms (diff opts) d opts in + let diff_rec diff opts ts = diff_terms (diff opts) d opts ts in let d_f = difference f_o f_n no_assumptions in let d_args = difference args_o args_n no_assumptions in (match get_change opts with | Kindofchange.InductiveType (_, _) -> - diff_rec diff_f opts d_f + diff_rec diff_f opts d_f evd | Kindofchange.FixpointCase ((_, _), cut) -> let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in - let fs = filter_diff_cut (diff_rec diff_f opts) d_f in + let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l evd)) d_f in if non_empty fs then - fs + evd, fs else let d_args_rev = reverse d_args in - filter_diff_cut (diff_map_flat (diff_rec diff_arg opts)) d_args_rev + evd, filter_diff_cut (fun ts -> snd (diff_map_flat (fun ts -> diff_rec diff_arg opts ts) ts Evd.empty)) d_args_rev | Kindofchange.ConclusionCase cut when isConstruct f_o && isConstruct f_n -> - let diff_arg o d = if no_diff evd o d then give_up else diff_arg o d in - filter_diff + let diff_arg o d evd = if snd (no_diff o d evd) then evd, give_up else diff_arg o d evd in + evd, filter_diff (fun args -> if Option.has_some cut then let args_lambdas = List.map (reconstruct_lambda env) args in snd (filter_applies_cut env (Option.get cut) args_lambdas evd) else args) - (diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion))) + (fun l -> snd (diff_map_flat (fun t -> diff_rec diff_arg (set_change opts Kindofchange.Conclusion) t) l Evd.empty)) d_args | Kindofchange.Hypothesis (_, _) -> let old_goal = fst (old_proof d) in @@ -99,24 +100,24 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi let goal_type = mkProd (Names.Name.Anonymous, g_n, shift g_o) in let filter_goal trms = snd (filter_by_type goal_type env evd trms) in let filter_diff_h diff = filter_diff filter_goal diff in - let fs = filter_diff_h (diff_rec diff_f opts) d_f in + let fs = filter_diff_h (fun l -> snd (diff_rec diff_f opts l evd)) d_f in if non_empty fs then - fs + evd, fs else - filter_diff_h (diff_map_flat (diff_rec diff_arg opts)) d_args + evd, filter_diff_h (fun d_args -> snd (diff_map_flat (fun t -> diff_rec diff_arg opts t) d_args Evd.empty)) d_args | Kindofchange.Conclusion | Kindofchange.Identity -> if List.for_all2 (convertible env evd) (Array.to_list args_o) (Array.to_list args_n) then let specialize f args = snd (specialize_using specialize_no_reduce env f args evd) in let combine_app = combine_cartesian specialize in - let fs = diff_rec diff_f opts d_f in + let _, fs = diff_rec diff_f opts d_f evd in let args = Array.map (fun a_o -> [a_o]) args_o in - combine_app fs (combine_cartesian_append args) + evd, combine_app fs (combine_cartesian_append args) else - give_up + evd, give_up | _ -> - give_up) + evd, give_up) | _ -> - give_up + evd, give_up (* * Search an application of an induction principle. @@ -125,7 +126,7 @@ let diff_app (evd : evar_map) diff_f diff_arg opts (d : goal_proof_diff) : candi * * For changes in constructors, hypotheses, or fixpoint cases, don't specialize. *) -let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = +let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (diff_arg : Differencers.proof_differencer configurable) opts (d : goal_proof_diff) evd = let d_proofs = erase_goals d in let o = old_proof d_proofs in let n = new_proof d_proofs in @@ -136,20 +137,20 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = let assums = assumptions d_zoom in let (o, npms_old, args_o) = old_proof d_zoom in let (n, npms_new, args_n) = new_proof d_zoom in - let f = diff_ind opts evd (difference (o, npms_old) (n, npms_new) assums) in + let _, f = diff_ind opts (difference (o, npms_old) (n, npms_new) assums) evd in match get_change opts with | (Kindofchange.InductiveType (_, _)) | (Kindofchange.Hypothesis (_, _)) -> - f + evd, f | Kindofchange.FixpointCase ((_, _), cut) -> let env = context_env (fst (old_proof d)) in - let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in + let filter_diff_cut diff d : candidates = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff d in if non_empty f then - f + evd, f else - let diff_rec diff opts = diff_terms (diff opts evd) d opts in + let diff_rec diff opts = diff_terms (diff opts) d opts in let d_args = difference (Array.of_list args_o) (Array.of_list args_n) no_assumptions in let d_args_rev = reverse d_args in - filter_diff_cut (diff_map_flat (diff_rec diff_arg opts)) d_args_rev + evd, filter_diff_cut (fun d -> snd (diff_map_flat (fun t sigma -> diff_rec diff_arg opts t Evd.empty) d Evd.empty)) d_args_rev | _ -> if non_empty args_o then let env_o = context_env (fst (old_proof d)) in @@ -168,7 +169,7 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = let specialize f args = snd (specialize_using specialize_no_reduce env_o f args evd) in let final_args_o = Array.of_list (fst (split_at arity args_o)) in if Kindofchange.is_identity (get_change opts) then (* TODO explain *) - List.map + evd, List.map (fun f -> let dummy_arg = mkRel 1 in specialize (specialize f final_args_o) (Array.make 1 dummy_arg)) @@ -179,14 +180,14 @@ let diff_app_ind evd diff_ind diff_arg opts (d : goal_proof_diff) : candidates = let args = Array.of_list (diff_map - (fun d_a -> + (fun d_a sigma -> let arg_n = new_proof d_a in let apply p = specialize p (Array.make 1 arg_n) in - let diff_apply = filter_diff (List.map apply) in - diff_terms (diff_apply (diff_arg opts evd)) d opts d_a) + let diff_apply di d : candidates = filter_diff (List.map apply) di d in + diff_terms (fun ts sigma -> sigma, diff_apply (fun d -> snd (diff_arg opts d Evd.empty)) ts) d opts d_a sigma) d_args) - in combine_cartesian specialize f (combine_cartesian_append args) + in evd, combine_cartesian specialize f (combine_cartesian_append args) else - f + evd, f else - give_up + evd, give_up diff --git a/plugin/src/core/components/differencing/appdifferencers.mli b/plugin/src/core/components/differencing/appdifferencers.mli index 6ee3fa7..e42cecc 100644 --- a/plugin/src/core/components/differencing/appdifferencers.mli +++ b/plugin/src/core/components/differencing/appdifferencers.mli @@ -11,7 +11,6 @@ open Evd * Use the options to determine how to combine the results. *) val diff_app : - evar_map -> proof_differencer configurable -> (* diff f *) proof_differencer configurable -> (* diff each arg *) proof_differencer configurable @@ -24,8 +23,7 @@ val diff_app : * Use the options to determine how to combine the results. *) val diff_app_ind : - evar_map -> - (evar_map -> ind_proof_differencer) configurable -> (* diff f *) - (evar_map -> proof_differencer) configurable -> (* diff each arg *) + ind_proof_differencer configurable -> (* diff f *) + proof_differencer configurable -> (* diff each arg *) proof_differencer configurable diff --git a/plugin/src/core/components/differencing/differencers.ml b/plugin/src/core/components/differencing/differencers.ml index 9f896b4..f571c21 100644 --- a/plugin/src/core/components/differencing/differencers.ml +++ b/plugin/src/core/components/differencing/differencers.ml @@ -8,10 +8,10 @@ open Kindofchange open Evd open Stateutils -type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove later *) +type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove when done *) type ('a, 'b) differencer_todo = 'a proof_diff -> evar_map -> 'b state -type 'a candidate_differencer = ('a, candidates) differencer +type 'a candidate_differencer = ('a, candidates) differencer_todo type proof_differencer = (context_object * proof_cat) candidate_differencer type term_differencer = types candidate_differencer type ind_proof_differencer = (proof_cat * int) candidate_differencer @@ -23,6 +23,6 @@ type arr_list_differencer = (types array) candidate_list_differencer type 'a change_detector = ('a, kind_of_change) differencer_todo type proof_change_detector = (context_object * proof_cat) change_detector -type 'a predicate_differencer = ('a, bool) differencer +type 'a predicate_differencer = ('a, bool) differencer_todo type proof_diff_predicate = (context_object * proof_cat) predicate_differencer diff --git a/plugin/src/core/components/differencing/differencers.mli b/plugin/src/core/components/differencing/differencers.mli index 07576de..aedb1d1 100644 --- a/plugin/src/core/components/differencing/differencers.mli +++ b/plugin/src/core/components/differencing/differencers.mli @@ -11,7 +11,7 @@ open Stateutils type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove when done *) type ('a, 'b) differencer_todo = 'a proof_diff -> evar_map -> 'b state -type 'a candidate_differencer = ('a, candidates) differencer +type 'a candidate_differencer = ('a, candidates) differencer_todo type proof_differencer = (context_object * proof_cat) candidate_differencer type term_differencer = types candidate_differencer type ind_proof_differencer = (proof_cat * int) candidate_differencer @@ -23,5 +23,5 @@ type arr_list_differencer = (types array) candidate_list_differencer type 'a change_detector = ('a, kind_of_change) differencer_todo type proof_change_detector = (context_object * proof_cat) change_detector -type 'a predicate_differencer = ('a, bool) differencer +type 'a predicate_differencer = ('a, bool) differencer_todo type proof_diff_predicate = (context_object * proof_cat) predicate_differencer diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index a1725ad..d2694e2 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -83,46 +83,48 @@ let debug_search (d : goal_proof_diff) : unit = * recursively. (Support for this is preliminary.) *) let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidates = + let diff_o = diff in + let diff opts d evd = evd, diff opts evd d in let d = snd (reduce_letin (snd (reduce_casts d Evd.empty)) Evd.empty) in - if no_diff evd opts d then - (*1*) identity_candidates d + if snd (no_diff opts d evd) then + (*1*) snd (identity_candidates d (Evd.from_env (Proofcatterms.context_env (fst (new_proof d))))) else if induct_over_same_h (same_h opts) d then try_chain_diffs - [(diff_app_ind evd (diff_inductive diff d) diff opts); (* 2a *) - (find_difference evd opts)] (* 2b *) + [(diff_app_ind (diff_inductive diff d) diff opts); (* 2a *) + (find_difference opts)] (* 2b *) d + evd else if applies_ih opts d then - let diff opts = diff opts evd in - (*3*) diff_app evd diff diff opts (snd (reduce_trim_ihs d Evd.empty)) + (*3*) snd (diff_app diff diff opts (snd (reduce_trim_ihs d Evd.empty)) evd) else - let diff opts = diff opts evd in match map_tuple kind (proof_terms d) with | (Lambda (n_o, t_o, b_o), Lambda (_, t_n, b_n)) -> let change = get_change opts in let ind = is_ind opts in let opts_hypos = if is_identity change then set_change opts Conclusion else opts in - if no_diff evd opts_hypos (snd (eval_with_terms t_o t_n d Evd.empty)) then - (*4*) snd (zoom_wrap_lambda (to_search_function diff opts d) n_o t_o d Evd.empty) + if snd (no_diff opts_hypos (snd (eval_with_terms t_o t_n d Evd.empty)) evd) then + (*4*) snd (zoom_wrap_lambda (to_search_function (fun opts -> diff_o opts evd) opts d) n_o t_o d Evd.empty) else if ind || not (is_conclusion change || is_identity change) then - (*5*) snd (zoom_unshift (to_search_function diff opts d) d Evd.empty) + (*5*) snd (zoom_unshift (to_search_function (fun opts -> diff_o opts evd) opts d) d Evd.empty) else give_up | _ -> if is_app opts d then try_chain_diffs - [(find_difference evd opts); (* 6a *) - (diff_app evd diff diff opts); (* 6b *) + [(find_difference opts); (* 6a *) + (diff_app diff diff opts); (* 6b *) (diff_reduced (diff opts))] (* 6c *) d + evd else give_up (* --- Top-level differencer --- *) (* Given a configuration, return the appropriate differencer *) -let get_differencer (opts : options) (evd : evar_map) = +let get_differencer (opts : options) = let should_reduce = is_inductive_type (get_change opts) in if should_reduce then - (fun d -> diff opts evd (snd (reduce_diff reduce_term d Evd.empty))) + (fun d evd -> evd, diff opts evd (snd (reduce_diff reduce_term d Evd.empty))) else - diff opts evd + (fun d evd -> evd, diff opts evd d) diff --git a/plugin/src/core/components/differencing/differencing.mli b/plugin/src/core/components/differencing/differencing.mli index 2ec0158..ee983d7 100644 --- a/plugin/src/core/components/differencing/differencing.mli +++ b/plugin/src/core/components/differencing/differencing.mli @@ -7,4 +7,4 @@ open Evd (* * Given a configuration, return the appropriate top-level differencer *) -val get_differencer : (evar_map -> proof_differencer) configurable +val get_differencer : proof_differencer configurable diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index 337c522..f54577d 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -49,13 +49,13 @@ let rec get_goal_fix env evd (d : types proof_diff) : candidates = (get_goal_fix (push_rel CRD.(LocalAssum(n1, t1)) env) evd (difference b1 b2 assums)) | _ -> let reduce_hd = reduce_unfold_whd env evd in - let rec get_goal_reduced d = + let rec get_goal_reduced d : candidates = let _, red_old = reduce_hd (old_proof d) in let _, red_new = reduce_hd (new_proof d) in match map_tuple kind (red_old, red_new) with | (App (f1, args1), App (f2, args2)) when equal f1 f2 -> let d_args = difference args1 args2 no_assumptions in - diff_map_flat get_goal_reduced d_args + snd (diff_map_flat (fun t sigma -> sigma, get_goal_reduced t) d_args Evd.empty) | _ when not (equal red_old red_new) -> [snd (reduce_unfold env evd (mkProd (Names.Name.Anonymous, red_old, shift red_new)))] | _ -> @@ -74,7 +74,7 @@ let rec diff_fix_case env evd (d : types proof_diff) : candidates = | (Case (_, ct1, m1, bs1), Case (_, ct2, m2, bs2)) when conv m1 m2 -> if Array.length bs1 = Array.length bs2 then let env_m = push_rel CRD.(LocalAssum(Names.Name.Anonymous, m1)) env in - let diff_bs = diff_map_flat (get_goal_fix env_m evd) in + let diff_bs l = snd (diff_map_flat (fun t sigma -> sigma, get_goal_fix env_m evd t) l evd) in List.map unshift (List.append @@ -93,7 +93,7 @@ let rec diff_fix_case env evd (d : types proof_diff) : candidates = * This operates at the term level, since compilation currently * doesn't model fixpoints. *) -let diff_fix_cases env evd (d : types proof_diff) : candidates = +let diff_fix_cases env (d : types proof_diff) evd : candidates Stateutils.state = let old_term = unwrap_definition env (old_proof d) in let new_term = unwrap_definition env (new_proof d) in let assums = assumptions d in @@ -102,13 +102,13 @@ let diff_fix_cases env evd (d : types proof_diff) : candidates = if List.for_all2 (convertible env evd) (Array.to_list tso) (Array.to_list tsn) then let env_fix = push_rel_context (bindings_for_fix nso tso) env in let d_ds = difference dso dsn assums in - let ds = diff_map_flat (diff_fix_case env_fix evd) d_ds in + let ds = snd (diff_map_flat (fun t sigma -> sigma, diff_fix_case env_fix evd t) d_ds evd) in let lambdas = List.map (reconstruct_lambda env_fix) ds in let apps = List.map (fun t -> mkApp (t, Array.make 1 new_term)) lambdas - in unique equal (snd (reduce_all reduce_term env evd apps)) + in evd, unique equal (snd (reduce_all reduce_term env evd apps)) else failwith "Cannot infer goals for generalizing change in definition" | _ -> diff --git a/plugin/src/core/components/differencing/fixdifferencers.mli b/plugin/src/core/components/differencing/fixdifferencers.mli index b808190..71d868f 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.mli +++ b/plugin/src/core/components/differencing/fixdifferencers.mli @@ -10,4 +10,4 @@ open Evd * This operates at the term level, since compilation currently * doesn't model fixpoints. *) -val diff_fix_cases : env -> evar_map -> term_differencer +val diff_fix_cases : env -> term_differencer diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index bd6cea2..c7ec20a 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -12,14 +12,14 @@ open Searchopts * Try to difference with one differencer * If that fails, then try the next one *) -let rec try_chain_diffs diffs d = +let rec try_chain_diffs diffs d evd = match diffs with | diff_h :: diff_t -> - let cs = diff_h d in + let cs = snd (diff_h d evd) in if non_empty cs then cs else - try_chain_diffs diff_t d + try_chain_diffs diff_t d evd | _ -> give_up @@ -28,14 +28,14 @@ let rec try_chain_diffs diffs d = * If reducing does not change the term, then give_up to prevent * inifinite recursion *) -let diff_reduced diff d = +let diff_reduced diff d sigma = let (o, n) = proof_terms d in let d_red = snd (reduce_diff reduce_term d Evd.empty) in let (o_red, n_red) = proof_terms d_red in if not ((equal o o_red) && (equal n n_red)) then - diff d_red + diff d_red Evd.empty else - give_up + Evd.empty, give_up (* * Convert a differencing function that takes a diff into one between two terms @@ -44,8 +44,8 @@ let diff_reduced diff d = * 1. Update the terms and goals of the diff d to use those terms * 2. Apply the differencing function to the new diff *) -let diff_terms (diff : proof_differencer) d opts d_t : candidates = - diff (snd (update_terms_goals opts (old_proof d_t) (new_proof d_t) d Evd.empty)) +let diff_terms (diff : proof_differencer) d opts d_t sigma = + diff (snd (update_terms_goals opts (old_proof d_t) (new_proof d_t) d Evd.empty)) Evd.empty (* * Recursively difference each term in a diff of arrays @@ -53,7 +53,7 @@ let diff_terms (diff : proof_differencer) d opts d_t : candidates = let diff_map (diff : term_differencer) d_arr = let assums = assumptions d_arr in List.map2 - (fun t_o t_n -> diff (difference t_o t_n assums)) + (fun t_o t_n -> snd (diff (difference t_o t_n assums) Evd.empty)) (Array.to_list (old_proof d_arr)) (Array.to_list (new_proof d_arr)) @@ -61,8 +61,8 @@ let diff_map (diff : term_differencer) d_arr = * Recursively difference each term in a diff of arrays * Flatten the result *) -let diff_map_flat (diff : term_differencer) d_arr = - List.flatten (diff_map diff d_arr) +let diff_map_flat (diff : term_differencer) d_arr sigma = + Evd.empty, List.flatten (diff_map diff d_arr) (* * Apply some differencing function diff --git a/plugin/src/core/components/differencing/higherdifferencers.mli b/plugin/src/core/components/differencing/higherdifferencers.mli index 66f7f0e..6181510 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.mli +++ b/plugin/src/core/components/differencing/higherdifferencers.mli @@ -2,6 +2,7 @@ open Searchopts open Proofdiff open Candidates open Differencers +open Evd (* --- Recursive differencing --- *) @@ -10,7 +11,7 @@ open Differencers * If that fails, then try the next one, and so on *) val try_chain_diffs : - ('a candidate_differencer) list -> 'a proof_diff -> candidates + ('a candidate_differencer) list -> 'a proof_diff -> evar_map -> candidates (* * Reduce and then diff diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 53fc193..670fb49 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -33,7 +33,7 @@ open Stateutils * To improve this, we need benchmarks for which the head is not the patch, * but another arrow is. *) -let rec diff_case abstract diff evd (d : goal_case_diff) : candidates = +let rec diff_case abstract (diff : Differencers.proof_differencer) evd (d : goal_case_diff) : candidates = let d_goal = erase_proofs d in match diff_proofs d with | ((h1 :: t1), (h2 :: t2)) -> @@ -41,7 +41,7 @@ let rec diff_case abstract diff evd (d : goal_case_diff) : candidates = (try let _, c1 = eval_proof_arrow h1 Evd.empty in let _, c2 = eval_proof_arrow h2 Evd.empty in - let cs = abstract (diff evd (add_to_diff d_goal c1 c2)) in + let cs = abstract (snd (diff (add_to_diff d_goal c1 c2) evd)) in if non_empty cs then cs else @@ -66,7 +66,7 @@ let rec diff_case abstract diff evd (d : goal_case_diff) : candidates = * we don't lift, but we could eventually try to apply the induction * principle for the constructor version to get a more general patch. *) -let diff_ind_case opts evd diff (d : goal_case_diff) : candidates = +let diff_ind_case opts evd (diff : Differencers.proof_differencer) (d : goal_case_diff) : candidates = diff_case (fun c -> snd (abstract_case opts d c evd)) diff evd d (* @@ -76,7 +76,7 @@ let diff_ind_case opts evd diff (d : goal_case_diff) : candidates = * This breaks it up into arrows and then searches those * in the order of the sort function. *) -let diff_sort_ind_case opts evd sort diff d_old (d : proof_cat_diff) : candidates = +let diff_sort_ind_case opts evd sort (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = let o = old_proof d in let n = new_proof d in let ms_o = morphisms o in @@ -106,7 +106,7 @@ let diff_sort_ind_case opts evd sort diff d_old (d : proof_cat_diff) : candidate (* * Base case: Prefer arrows later in the proof *) -let diff_base_case opts evd diff d_old (d : proof_cat_diff) : candidates = +let diff_base_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = let sort _ ms = List.rev ms in diff_sort_ind_case (set_is_ind opts false) evd sort diff d_old d @@ -121,7 +121,7 @@ let diff_base_case opts evd diff d_old (d : proof_cat_diff) : candidates = * For optimization, we don't bother treating the inductive case * any differently, since the IH does not change. *) -let diff_inductive_case opts evd diff d_old (d : proof_cat_diff) : candidates = +let diff_inductive_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = let sort c ms = List.stable_sort (fun m1 m2 -> snd (closer_to_ih c (find_ihs c) m1 m2 Evd.empty)) ms in let change = get_change opts in let opts = if is_identity change then opts else set_is_ind opts true in @@ -132,7 +132,7 @@ let diff_inductive_case opts evd diff d_old (d : proof_cat_diff) : candidates = * it treating it either like a base case (no inductive hypotheses) * or an inductive case (some inductive hypotheses). *) -let diff_base_or_inductive_case opts evd diff d_old (d : proof_cat_diff) : candidates = +let diff_base_or_inductive_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = let o = old_proof d in if has_ihs o then diff_inductive_case opts evd diff d_old d @@ -146,7 +146,7 @@ let diff_base_or_inductive_case opts evd diff d_old (d : proof_cat_diff) : candi * If there is a bug here, then the offset we unshift by may not generalize * for all cases. *) -let diff_and_unshift_case opts evd diff d_old (d : proof_cat_diff) : candidates = +let diff_and_unshift_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = List.map (fun trm -> if is_conclusion (get_change opts) then @@ -162,7 +162,7 @@ let diff_and_unshift_case opts evd diff d_old (d : proof_cat_diff) : candidates * For now, we only return the first patch we find. * We may want to return more later. *) -let rec diff_ind_cases opts evd diff d_old (ds : proof_cat_diff list) : candidates = +let rec diff_ind_cases opts evd (diff : Differencers.proof_differencer configurable) d_old (ds : proof_cat_diff list) : candidates = match ds with | d :: tl -> let patches = diff_and_unshift_case opts evd diff d_old d in @@ -184,21 +184,20 @@ let rec diff_ind_cases opts evd diff d_old (ds : proof_cat_diff list) : candidat * This does not yet handle the case when the inductive parameters * are lists of different lengths, or where there is a change in hypothesis. *) -let diff_inductive diff d_old opts evd (d : (proof_cat * int) proof_diff) : candidates = +let diff_inductive (diff : Differencers.proof_differencer configurable) d_old opts (d : (proof_cat * int) proof_diff) evd = let (o, nparams_o) = old_proof d in let (n, nparams_n) = new_proof d in if not (nparams_o = nparams_n) then - give_up + Evd.empty, give_up else - snd - (zoom_map - (fun d sigma -> - let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in - let d_sorted = map_diffs sort id d in - let ds = dest_cases d_sorted in - map_state (fun d -> ret (unshift_by nparams_o d)) (diff_ind_cases opts evd diff d_old ds) Evd.empty) - [] - ret - (intro_params nparams_o) - (difference o n (assumptions d)) - Evd.empty) + zoom_map + (fun d sigma -> + let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in + let d_sorted = map_diffs sort id d in + let ds = dest_cases d_sorted in + map_state (fun d -> ret (unshift_by nparams_o d)) (diff_ind_cases opts evd diff d_old ds) Evd.empty) + [] + ret + (intro_params nparams_o) + (difference o n (assumptions d)) + Evd.empty diff --git a/plugin/src/core/components/differencing/inddifferencers.mli b/plugin/src/core/components/differencing/inddifferencers.mli index 0197d15..794a00e 100644 --- a/plugin/src/core/components/differencing/inddifferencers.mli +++ b/plugin/src/core/components/differencing/inddifferencers.mli @@ -18,6 +18,6 @@ open Evd * to update the goals for the next iteration. *) val diff_inductive : - (evar_map -> proof_differencer) configurable -> + proof_differencer configurable -> goal_proof_diff -> - (evar_map -> ind_proof_differencer) configurable + ind_proof_differencer configurable diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index fe24a99..9042873 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -17,6 +17,8 @@ open Zooming open Contextutils open Idutils open Stateutils +open Convertibility +open Envutils (* --- TODO for refactoring without breaking things --- *) @@ -24,13 +26,12 @@ open Stateutils * Infer the type of trm in env * Note: This does not yet use good evar map hygeine; will fix that * during the refactor. + * + * TODO fix this last *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = +let infer_type (env : env) (evd : evar_map) (trm : types) = let jmt = Typeops.infer env trm in - j_type jmt - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) + evd, j_type jmt (* --- End TODO --- *) @@ -53,26 +54,28 @@ let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible en * are similar to the problems we encounter in general when * abstracting candidates. *) -let sub_new_ih is_ind num_new_rels env evd (old_term : types) : types = +let sub_new_ih is_ind num_new_rels env (old_term : types) sigma = if is_ind then let ih_new = mkRel (1 + num_new_rels) in - snd (all_typ_substs env evd (ih_new, ih_new) old_term) (* TODO evar_map *) + all_typ_substs env sigma (ih_new, ih_new) old_term else - old_term + sigma, old_term (* * Merge the environments in a diff and factor out the enviroment * Subtitute in the inductive hypothesis if in the inductive case *) -let merge_diff_envs is_ind num_new_rels evd (d : goal_type_term_diff) = +let merge_diff_envs is_ind num_new_rels (d : goal_type_term_diff) = let assums = assumptions d in let (env, ns, os) = merge_diff_closures d [] in let [new_goal_type; new_term] = ns in let [old_goal_type; old_term] = os in - let old_term_sub = sub_new_ih is_ind num_new_rels env evd old_term in - let n = (new_goal_type, new_term) in - let o = (old_goal_type, old_term_sub) in - (env, difference o n assums) + bind + (sub_new_ih is_ind num_new_rels env old_term) + (fun old_term_sub -> + let n = (new_goal_type, new_term) in + let o = (old_goal_type, old_term_sub) in + ret (env, difference o n assums)) (* --- Differencing of Proofs --- *) @@ -94,22 +97,34 @@ let merge_diff_envs is_ind num_new_rels evd (d : goal_type_term_diff) = * * For optimization, we just return the original term. *) -let build_app_candidates env evd opts (from_type : types) (old_term : types) (new_term : types) = +let build_app_candidates_no_red env opts from_type old_term new_term = try - let env_b = push_rel CRD.(LocalAssum(Name.Anonymous, from_type)) env in + let env_b = push_local (Name.Anonymous, from_type) env in let old_term_shift = shift old_term in - let bodies = - if is_identity (get_change opts) then + bind + (if is_identity (get_change opts) then (* the difference between a term and nothing is the term *) - [old_term_shift] + ret [old_term_shift] else (* otherwise, check containment *) let new_term_shift = shift new_term in - let sub tr = snd (all_conv_substs_combs env_b evd (new_term_shift, (mkRel 1)) tr) in (* TODO evar_map *) - snd (filter_not_same old_term_shift env_b evd (sub old_term_shift)) - in List.map (fun b -> reconstruct_lambda_n env_b b (nb_rel env)) bodies + bind + (fun sigma -> + let sub = (new_term_shift, mkRel 1) in + all_conv_substs_combs env_b sigma sub old_term_shift) + (fun subbed sigma -> + filter_not_same old_term_shift env_b sigma subbed)) + (map_state (fun b -> ret (reconstruct_lambda_n env_b b (nb_rel env)))) with _ -> - give_up + ret give_up + +(* + * Build app candidates, then remove identity functions + *) +let build_app_candidates env opts from_type old_term new_term = + bind + (build_app_candidates_no_red env opts from_type old_term new_term) + (fun cs sigma -> reduce_all reduce_remove_identities env sigma cs) (* * Given two proof terms that apply functions, old and new, @@ -136,52 +151,66 @@ let build_app_candidates env evd opts (from_type : types) (old_term : types) (ne * * Currently heuristics-driven, and does not work for all cases. *) -let find_difference evd (opts : options) (d : goal_proof_diff) : candidates = +let find_difference (opts : options) (d : goal_proof_diff) = let d = proof_to_term d in let d = swap_search_goals opts d in let d_dest = dest_goals d in let num_new_rels = num_new_bindings (fun o -> snd (fst o)) d_dest in let is_ind = is_ind opts in - let (env_merge, d_merge) = merge_diff_envs is_ind num_new_rels evd d_dest in - let (old_goal_type, old_term) = old_proof d_merge in - let (new_goal_type, new_term) = new_proof d_merge in - let change = get_change opts in - let from_type = - if is_hypothesis change then - new_goal_type - else - infer_type env_merge evd new_term - in - let candidates = build_app_candidates env_merge evd opts from_type old_term new_term in - let goal_type = mkProd (Name.Anonymous, new_goal_type, shift old_goal_type) in - let _, reduced = reduce_all reduce_remove_identities env_merge evd candidates in - let filter = filter_by_type goal_type env_merge evd in - List.map - (unshift_local (num_new_rels - 1) num_new_rels) - (snd (filter (if is_ind then snd (filter_ihs env_merge evd reduced) else reduced))) - + bind + (merge_diff_envs is_ind num_new_rels d_dest) + (fun (env, d) -> + let (old_goal_type, old_term) = old_proof d in + let (new_goal_type, new_term) = new_proof d in + let goal_type = mkProd (Name.Anonymous, new_goal_type, shift old_goal_type) in + let change = get_change opts in + bind + (if is_hypothesis change then + ret new_goal_type + else + fun sigma -> infer_type env sigma new_term) + (fun from_type -> + bind + (build_app_candidates env opts from_type old_term new_term) + (fun cs -> + let unshift_c = unshift_local (num_new_rels - 1) num_new_rels in + let filter_gt l sigma = filter_by_type goal_type env sigma l in + let filter l = + bind + (branch_state + (fun _ -> ret is_ind) + (fun l sigma -> filter_ihs env sigma l) + ret + l) + filter_gt + in bind (filter cs) (fun l -> ret (List.map unshift_c l))))) + (* Determine if two diffs are identical (convertible). *) -let no_diff evd opts (d : goal_proof_diff) : bool = +let no_diff opts (d : goal_proof_diff) = let change = get_change opts in if is_identity change then (* there is always a difference between the term and nothing *) - false + ret false else (* check convertibility *) let d_term = proof_to_term d in let d_dest = dest_goals d_term in let num_new_rels = num_new_bindings (fun o -> snd (fst o)) d_dest in - let (env, d_merge) = merge_diff_envs false num_new_rels evd d_dest in - let (_, old_term) = old_proof d_merge in - let (_, new_term) = new_proof d_merge in - let conv = convertible env evd old_term new_term in - match change with - | FixpointCase ((d_old, d_new), _) -> - conv - || (equal d_old old_term && equal d_new new_term) - || (equal d_old new_term && equal d_new old_term) - | _ -> - conv + bind + (merge_diff_envs false num_new_rels d_dest) + (fun (env, d_merge) -> + let (_, old_term) = old_proof d_merge in + let (_, new_term) = new_proof d_merge in + bind + (fun sigma -> convertible env sigma old_term new_term) + (fun conv -> + match change with + | FixpointCase ((d_old, d_new), _) -> + ret (conv + || (equal d_old old_term && equal d_new new_term) + || (equal d_old new_term && equal d_new old_term)) + | _ -> + ret conv)) (* * Given a difference in proofs with contexts storing the goals, @@ -190,11 +219,10 @@ let no_diff evd opts (d : goal_proof_diff) : bool = * * TODO: This is incorrect in some cases: * Inside of lambdas, we need to adjust this. - * - * TODO better evar_map hygiene *) -let identity_candidates (d : goal_proof_diff) : candidates = +let identity_candidates (d : goal_proof_diff) = let (new_goal, _) = new_proof d in - let env = context_env new_goal in - let sigma = Evd.from_env env in - [snd (identity_term (context_env new_goal) sigma (context_term new_goal))] + bind + (fun sigma -> + identity_term (context_env new_goal) sigma (context_term new_goal)) + (fun t -> ret [t]) diff --git a/plugin/src/core/components/differencing/proofdifferencers.mli b/plugin/src/core/components/differencing/proofdifferencers.mli index 43771d6..4c7e8f2 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.mli +++ b/plugin/src/core/components/differencing/proofdifferencers.mli @@ -7,12 +7,12 @@ open Differencers (* * Primitive differencing function *) -val find_difference : evar_map -> proof_differencer configurable +val find_difference : proof_differencer configurable (* * Determine if two proof diffs are identical *) -val no_diff : evar_map -> proof_diff_predicate configurable +val no_diff : proof_diff_predicate configurable (* * Return the identity candidates applied to the type diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index e86192c..ec25c8a 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -55,7 +55,7 @@ let return_patch opts env evd (patches : types list) : types = (fun ss -> snd (abstract_with_strategies ss evd)) (snd (configure_fixpoint_cases env - (diff_fix_cases env evd (difference old_type new_type no_assumptions)) + (snd (diff_fix_cases env (difference old_type new_type no_assumptions) evd)) specialized_fs_terms evd)) in List.hd generalized (* TODO better failure when none found *) @@ -83,13 +83,13 @@ let search_for_patch evd (default : types) (opts : options) (d : goal_proof_diff let start_backwards = is_fixpoint_case change || is_hypothesis change in let d = if start_backwards then reverse d else d in (* explain *) let d = snd (update_search_goals opts d (erase_goals d) Evd.empty) in - let diff = get_differencer opts evd in - let patches = diff d in + let diff = get_differencer opts in + let _, patches = diff d evd in let ((_, env), _) = old_proof (dest_goals d) in if non_empty patches then return_patch opts env evd patches else - let rev_patches = diff (reverse d) in + let _, rev_patches = diff (reverse d) evd in Printf.printf "%s\n" "searched backwards"; Printf.printf "inverting %d candidates\n" (List.length rev_patches); let inverted = snd (invert_terms invert_factor env rev_patches evd) in From c115bc6cd12102f4d13d41f78edcea7cb7e59d4f Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 17:35:59 -0700 Subject: [PATCH 133/154] backwards compatibility in app diff --- .../core/components/differencing/appdifferencers.ml | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 5e2028e..a3a6010 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -76,7 +76,7 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : diff_rec diff_f opts d_f evd | Kindofchange.FixpointCase ((_, _), cut) -> let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in - let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l evd)) d_f in + let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l Evd.empty)) d_f in if non_empty fs then evd, fs else @@ -100,7 +100,7 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : let goal_type = mkProd (Names.Name.Anonymous, g_n, shift g_o) in let filter_goal trms = snd (filter_by_type goal_type env evd trms) in let filter_diff_h diff = filter_diff filter_goal diff in - let fs = filter_diff_h (fun l -> snd (diff_rec diff_f opts l evd)) d_f in + let fs = filter_diff_h (fun l -> snd (diff_rec diff_f opts l Evd.empty)) d_f in if non_empty fs then evd, fs else @@ -147,7 +147,7 @@ let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (d if non_empty f then evd, f else - let diff_rec diff opts = diff_terms (diff opts) d opts in + let diff_rec diff opts = diff_terms (fun d _ -> diff opts d evd) d opts in let d_args = difference (Array.of_list args_o) (Array.of_list args_n) no_assumptions in let d_args_rev = reverse d_args in evd, filter_diff_cut (fun d -> snd (diff_map_flat (fun t sigma -> diff_rec diff_arg opts t Evd.empty) d Evd.empty)) d_args_rev @@ -183,8 +183,8 @@ let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (d (fun d_a sigma -> let arg_n = new_proof d_a in let apply p = specialize p (Array.make 1 arg_n) in - let diff_apply di d : candidates = filter_diff (List.map apply) di d in - diff_terms (fun ts sigma -> sigma, diff_apply (fun d -> snd (diff_arg opts d Evd.empty)) ts) d opts d_a sigma) + let diff_apply = filter_diff (List.map apply) in + diff_terms (fun ts sigma -> sigma, diff_apply (fun d -> snd (diff_arg opts d evd)) ts) d opts d_a sigma) d_args) in evd, combine_cartesian specialize f (combine_cartesian_append args) else From fb2aea789b36bc12cd4281269a2a1d37e3b18990 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 17:40:44 -0700 Subject: [PATCH 134/154] more of that --- .../src/core/components/differencing/higherdifferencers.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index c7ec20a..0488046 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -33,9 +33,9 @@ let diff_reduced diff d sigma = let d_red = snd (reduce_diff reduce_term d Evd.empty) in let (o_red, n_red) = proof_terms d_red in if not ((equal o o_red) && (equal n n_red)) then - diff d_red Evd.empty + diff d_red sigma else - Evd.empty, give_up + sigma, give_up (* * Convert a differencing function that takes a diff into one between two terms @@ -45,7 +45,7 @@ let diff_reduced diff d sigma = * 2. Apply the differencing function to the new diff *) let diff_terms (diff : proof_differencer) d opts d_t sigma = - diff (snd (update_terms_goals opts (old_proof d_t) (new_proof d_t) d Evd.empty)) Evd.empty + diff (snd (update_terms_goals opts (old_proof d_t) (new_proof d_t) d Evd.empty)) sigma (* * Recursively difference each term in a diff of arrays From 0ca4ca21662af000db2f4e27a9434f5053b80a71 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 17:49:09 -0700 Subject: [PATCH 135/154] more --- plugin/src/core/components/differencing/appdifferencers.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index a3a6010..58115d8 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -73,7 +73,7 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : let d_args = difference args_o args_n no_assumptions in (match get_change opts with | Kindofchange.InductiveType (_, _) -> - diff_rec diff_f opts d_f evd + diff_rec diff_f opts d_f Evd.empty | Kindofchange.FixpointCase ((_, _), cut) -> let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l Evd.empty)) d_f in @@ -150,7 +150,7 @@ let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (d let diff_rec diff opts = diff_terms (fun d _ -> diff opts d evd) d opts in let d_args = difference (Array.of_list args_o) (Array.of_list args_n) no_assumptions in let d_args_rev = reverse d_args in - evd, filter_diff_cut (fun d -> snd (diff_map_flat (fun t sigma -> diff_rec diff_arg opts t Evd.empty) d Evd.empty)) d_args_rev + evd, filter_diff_cut (fun d -> snd (diff_map_flat (fun t sigma -> diff_rec diff_arg opts t evd) d Evd.empty)) d_args_rev | _ -> if non_empty args_o then let env_o = context_env (fst (old_proof d)) in From c99b2f0ceedd7979c4597384706910ed1bf46782 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 18:02:25 -0700 Subject: [PATCH 136/154] more. still buggy. ugh --- plugin/src/core/components/differencing/appdifferencers.ml | 3 ++- .../src/core/components/differencing/higherdifferencers.ml | 6 +++--- .../src/core/components/differencing/higherdifferencers.mli | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 58115d8..1540524 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -185,7 +185,8 @@ let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (d let apply p = specialize p (Array.make 1 arg_n) in let diff_apply = filter_diff (List.map apply) in diff_terms (fun ts sigma -> sigma, diff_apply (fun d -> snd (diff_arg opts d evd)) ts) d opts d_a sigma) - d_args) + d_args + evd) in evd, combine_cartesian specialize f (combine_cartesian_append args) else evd, f diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index 0488046..adbdc08 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -50,10 +50,10 @@ let diff_terms (diff : proof_differencer) d opts d_t sigma = (* * Recursively difference each term in a diff of arrays *) -let diff_map (diff : term_differencer) d_arr = +let diff_map (diff : term_differencer) d_arr sigma = let assums = assumptions d_arr in List.map2 - (fun t_o t_n -> snd (diff (difference t_o t_n assums) Evd.empty)) + (fun t_o t_n -> snd (diff (difference t_o t_n assums) sigma)) (Array.to_list (old_proof d_arr)) (Array.to_list (new_proof d_arr)) @@ -62,7 +62,7 @@ let diff_map (diff : term_differencer) d_arr = * Flatten the result *) let diff_map_flat (diff : term_differencer) d_arr sigma = - Evd.empty, List.flatten (diff_map diff d_arr) + Evd.empty, List.flatten (diff_map diff d_arr sigma) (* * Apply some differencing function diff --git a/plugin/src/core/components/differencing/higherdifferencers.mli b/plugin/src/core/components/differencing/higherdifferencers.mli index 6181510..964ef03 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.mli +++ b/plugin/src/core/components/differencing/higherdifferencers.mli @@ -32,7 +32,7 @@ val diff_terms : (* * Using some term differencer, recursively difference an array *) -val diff_map : term_differencer -> arr_list_differencer +val diff_map : term_differencer -> Constr.types array proof_diff -> evar_map -> candidates list (* TODO fix type after refactor *) (* * Using some term differencer, recursively difference an array From cae6b546f4d2c92242470f311408fc48b448d9a6 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 18:23:09 -0700 Subject: [PATCH 137/154] fix one more bug --- plugin/src/core/components/differencing/appdifferencers.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 1540524..5fc47b4 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -91,7 +91,7 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : snd (filter_applies_cut env (Option.get cut) args_lambdas evd) else args) - (fun l -> snd (diff_map_flat (fun t -> diff_rec diff_arg (set_change opts Kindofchange.Conclusion) t) l Evd.empty)) + (fun l -> snd (diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion)) l evd)) d_args | Kindofchange.Hypothesis (_, _) -> let old_goal = fst (old_proof d) in From 16aedc78f0038ec01f7edd040d120999b52a7cba Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Wed, 4 Sep 2019 19:56:23 -0700 Subject: [PATCH 138/154] fix all bugs --- plugin/src/core/components/differencing/appdifferencers.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 5fc47b4..ebfc6f5 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -73,15 +73,15 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : let d_args = difference args_o args_n no_assumptions in (match get_change opts with | Kindofchange.InductiveType (_, _) -> - diff_rec diff_f opts d_f Evd.empty + diff_rec diff_f opts d_f evd | Kindofchange.FixpointCase ((_, _), cut) -> let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in - let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l Evd.empty)) d_f in + let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l evd)) d_f in if non_empty fs then evd, fs else let d_args_rev = reverse d_args in - evd, filter_diff_cut (fun ts -> snd (diff_map_flat (fun ts -> diff_rec diff_arg opts ts) ts Evd.empty)) d_args_rev + evd, filter_diff_cut (fun ts -> snd (diff_map_flat (fun ts -> diff_rec diff_arg opts ts) ts evd)) d_args_rev | Kindofchange.ConclusionCase cut when isConstruct f_o && isConstruct f_n -> let diff_arg o d evd = if snd (no_diff o d evd) then evd, give_up else diff_arg o d evd in evd, filter_diff From 7fa35e7e09dd4f24ca041e950c459dc9576bc7ee Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 13:46:12 -0700 Subject: [PATCH 139/154] higher differencers with state --- .../differencing/appdifferencers.ml | 37 +++++++------- .../components/differencing/differencers.ml | 2 +- .../components/differencing/differencers.mli | 2 +- .../components/differencing/differencing.ml | 24 +++++---- .../differencing/higherdifferencers.ml | 51 ++++++++++--------- .../differencing/higherdifferencers.mli | 13 +++-- 6 files changed, 72 insertions(+), 57 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index ebfc6f5..afff01f 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -75,36 +75,37 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : | Kindofchange.InductiveType (_, _) -> diff_rec diff_f opts d_f evd | Kindofchange.FixpointCase ((_, _), cut) -> - let filter_diff_cut diff = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff in - let fs = filter_diff_cut (fun l -> snd (diff_rec diff_f opts l evd)) d_f in + let filter_diff_cut diff d = filter_diff (fun trms _ -> filter_cut env cut trms evd) diff d evd in + let _, fs = filter_diff_cut (fun l _ -> diff_rec diff_f opts l evd) d_f in if non_empty fs then evd, fs else let d_args_rev = reverse d_args in - evd, filter_diff_cut (fun ts -> snd (diff_map_flat (fun ts -> diff_rec diff_arg opts ts) ts evd)) d_args_rev + evd, snd (filter_diff_cut (fun ts _ -> diff_map_flat (fun ts -> diff_rec diff_arg opts ts) ts evd) d_args_rev) | Kindofchange.ConclusionCase cut when isConstruct f_o && isConstruct f_n -> let diff_arg o d evd = if snd (no_diff o d evd) then evd, give_up else diff_arg o d evd in - evd, filter_diff - (fun args -> + filter_diff + (fun args _ -> if Option.has_some cut then let args_lambdas = List.map (reconstruct_lambda env) args in - snd (filter_applies_cut env (Option.get cut) args_lambdas evd) + evd, snd (filter_applies_cut env (Option.get cut) args_lambdas evd) else - args) - (fun l -> snd (diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion)) l evd)) + evd, args) + (fun l _ -> diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion)) l evd) d_args + evd | Kindofchange.Hypothesis (_, _) -> let old_goal = fst (old_proof d) in let new_goal = fst (new_proof d) in let (g_o, g_n) = map_tuple context_term (old_goal, new_goal) in let goal_type = mkProd (Names.Name.Anonymous, g_n, shift g_o) in - let filter_goal trms = snd (filter_by_type goal_type env evd trms) in + let filter_goal trms evd = filter_by_type goal_type env evd trms in let filter_diff_h diff = filter_diff filter_goal diff in - let fs = filter_diff_h (fun l -> snd (diff_rec diff_f opts l Evd.empty)) d_f in + let _, fs = filter_diff_h (fun l _ -> diff_rec diff_f opts l Evd.empty) d_f evd in if non_empty fs then evd, fs else - evd, filter_diff_h (fun d_args -> snd (diff_map_flat (fun t -> diff_rec diff_arg opts t) d_args Evd.empty)) d_args + evd, snd (filter_diff_h (fun d_args _ -> diff_map_flat (fun t -> diff_rec diff_arg opts t) d_args Evd.empty) d_args evd) | Kindofchange.Conclusion | Kindofchange.Identity -> if List.for_all2 (convertible env evd) (Array.to_list args_o) (Array.to_list args_n) then let specialize f args = snd (specialize_using specialize_no_reduce env f args evd) in @@ -143,14 +144,14 @@ let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (d evd, f | Kindofchange.FixpointCase ((_, _), cut) -> let env = context_env (fst (old_proof d)) in - let filter_diff_cut diff d : candidates = filter_diff (fun trms -> snd (filter_cut env cut trms evd)) diff d in + let filter_diff_cut diff d = filter_diff (fun trms _ -> filter_cut env cut trms evd) diff d evd in if non_empty f then evd, f else let diff_rec diff opts = diff_terms (fun d _ -> diff opts d evd) d opts in let d_args = difference (Array.of_list args_o) (Array.of_list args_n) no_assumptions in let d_args_rev = reverse d_args in - evd, filter_diff_cut (fun d -> snd (diff_map_flat (fun t sigma -> diff_rec diff_arg opts t evd) d Evd.empty)) d_args_rev + filter_diff_cut (fun d _ -> diff_map_flat (fun t sigma -> diff_rec diff_arg opts t evd) d Evd.empty) d_args_rev | _ -> if non_empty args_o then let env_o = context_env (fst (old_proof d)) in @@ -179,14 +180,14 @@ let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (d let d_args = difference final_args_n final_args_o no_assumptions in let args = Array.of_list - (diff_map + (snd (diff_map (fun d_a sigma -> let arg_n = new_proof d_a in - let apply p = specialize p (Array.make 1 arg_n) in - let diff_apply = filter_diff (List.map apply) in - diff_terms (fun ts sigma -> sigma, diff_apply (fun d -> snd (diff_arg opts d evd)) ts) d opts d_a sigma) + let apply p = ret (specialize p (Array.make 1 arg_n)) in + let diff_apply = filter_diff (map_state apply) in + diff_terms (fun ts sigma -> diff_apply (fun d _ -> diff_arg opts d evd) ts Evd.empty) d opts d_a sigma) d_args - evd) + evd)) in evd, combine_cartesian specialize f (combine_cartesian_append args) else evd, f diff --git a/plugin/src/core/components/differencing/differencers.ml b/plugin/src/core/components/differencing/differencers.ml index f571c21..55d78a2 100644 --- a/plugin/src/core/components/differencing/differencers.ml +++ b/plugin/src/core/components/differencing/differencers.ml @@ -17,7 +17,7 @@ type term_differencer = types candidate_differencer type ind_proof_differencer = (proof_cat * int) candidate_differencer type arr_differencer = (types array) candidate_differencer -type 'a candidate_list_differencer = ('a, candidates list) differencer +type 'a candidate_list_differencer = ('a, candidates list) differencer_todo type arr_list_differencer = (types array) candidate_list_differencer type 'a change_detector = ('a, kind_of_change) differencer_todo diff --git a/plugin/src/core/components/differencing/differencers.mli b/plugin/src/core/components/differencing/differencers.mli index aedb1d1..46228ba 100644 --- a/plugin/src/core/components/differencing/differencers.mli +++ b/plugin/src/core/components/differencing/differencers.mli @@ -17,7 +17,7 @@ type term_differencer = types candidate_differencer type ind_proof_differencer = (proof_cat * int) candidate_differencer type arr_differencer = (types array) candidate_differencer -type 'a candidate_list_differencer = ('a, candidates list) differencer +type 'a candidate_list_differencer = ('a, candidates list) differencer_todo type arr_list_differencer = (types array) candidate_list_differencer type 'a change_detector = ('a, kind_of_change) differencer_todo diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index d2694e2..0b65313 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -89,11 +89,12 @@ let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidate if snd (no_diff opts d evd) then (*1*) snd (identity_candidates d (Evd.from_env (Proofcatterms.context_env (fst (new_proof d))))) else if induct_over_same_h (same_h opts) d then - try_chain_diffs - [(diff_app_ind (diff_inductive diff d) diff opts); (* 2a *) - (find_difference opts)] (* 2b *) - d - evd + snd + (try_chain_diffs + [(diff_app_ind (diff_inductive diff d) diff opts); (* 2a *) + (find_difference opts)] (* 2b *) + d + evd) else if applies_ih opts d then (*3*) snd (diff_app diff diff opts (snd (reduce_trim_ihs d Evd.empty)) evd) else @@ -110,12 +111,13 @@ let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidate give_up | _ -> if is_app opts d then - try_chain_diffs - [(find_difference opts); (* 6a *) - (diff_app diff diff opts); (* 6b *) - (diff_reduced (diff opts))] (* 6c *) - d - evd + snd + (try_chain_diffs + [(find_difference opts); (* 6a *) + (diff_app diff diff opts); (* 6b *) + (diff_reduced (diff opts))] (* 6c *) + d + evd) else give_up diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index adbdc08..fa1e633 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -5,6 +5,7 @@ open Candidates open Reducers open Differencers open Searchopts +open Stateutils (* --- Recursive differencing --- *) @@ -12,30 +13,34 @@ open Searchopts * Try to difference with one differencer * If that fails, then try the next one *) -let rec try_chain_diffs diffs d evd = +let rec try_chain_diffs diffs d = match diffs with | diff_h :: diff_t -> - let cs = snd (diff_h d evd) in - if non_empty cs then - cs - else - try_chain_diffs diff_t d evd + bind + (diff_h d) + (fun cs -> + if non_empty cs then + ret cs + else + try_chain_diffs diff_t d) | _ -> - give_up + ret give_up (* * Try to reduce and then diff * If reducing does not change the term, then give_up to prevent * inifinite recursion *) -let diff_reduced diff d sigma = +let diff_reduced diff d = let (o, n) = proof_terms d in - let d_red = snd (reduce_diff reduce_term d Evd.empty) in - let (o_red, n_red) = proof_terms d_red in - if not ((equal o o_red) && (equal n n_red)) then - diff d_red sigma - else - sigma, give_up + bind + (reduce_diff reduce_term d) + (fun d_red -> + let (o_red, n_red) = proof_terms d_red in + if not ((equal o o_red) && (equal n n_red)) then + diff d_red + else + ret give_up) (* * Convert a differencing function that takes a diff into one between two terms @@ -44,16 +49,16 @@ let diff_reduced diff d sigma = * 1. Update the terms and goals of the diff d to use those terms * 2. Apply the differencing function to the new diff *) -let diff_terms (diff : proof_differencer) d opts d_t sigma = - diff (snd (update_terms_goals opts (old_proof d_t) (new_proof d_t) d Evd.empty)) sigma +let diff_terms (diff : proof_differencer) d opts d_t = + bind (update_terms_goals opts (old_proof d_t) (new_proof d_t) d) diff (* * Recursively difference each term in a diff of arrays *) -let diff_map (diff : term_differencer) d_arr sigma = +let diff_map (diff : term_differencer) d_arr = let assums = assumptions d_arr in - List.map2 - (fun t_o t_n -> snd (diff (difference t_o t_n assums) sigma)) + map2_state + (fun t_o t_n -> diff (difference t_o t_n assums)) (Array.to_list (old_proof d_arr)) (Array.to_list (new_proof d_arr)) @@ -61,12 +66,12 @@ let diff_map (diff : term_differencer) d_arr sigma = * Recursively difference each term in a diff of arrays * Flatten the result *) -let diff_map_flat (diff : term_differencer) d_arr sigma = - Evd.empty, List.flatten (diff_map diff d_arr sigma) +let diff_map_flat (diff : term_differencer) d_arr = + bind (diff_map diff d_arr) (fun l -> ret (List.flatten l)) (* * Apply some differencing function * Filter the result using the supplied modifier *) -let filter_diff filter (diff : ('a, 'b) differencer) d : 'b = - filter (diff d) +let filter_diff filter (diff : ('a, 'b) differencer_todo) d = + bind (diff d) filter diff --git a/plugin/src/core/components/differencing/higherdifferencers.mli b/plugin/src/core/components/differencing/higherdifferencers.mli index 964ef03..5ca67f1 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.mli +++ b/plugin/src/core/components/differencing/higherdifferencers.mli @@ -3,6 +3,7 @@ open Proofdiff open Candidates open Differencers open Evd +open Stateutils (* --- Recursive differencing --- *) @@ -11,7 +12,10 @@ open Evd * If that fails, then try the next one, and so on *) val try_chain_diffs : - ('a candidate_differencer) list -> 'a proof_diff -> evar_map -> candidates + ('a candidate_differencer) list -> + 'a proof_diff -> + evar_map -> + candidates state (* * Reduce and then diff @@ -32,7 +36,7 @@ val diff_terms : (* * Using some term differencer, recursively difference an array *) -val diff_map : term_differencer -> Constr.types array proof_diff -> evar_map -> candidates list (* TODO fix type after refactor *) +val diff_map : term_differencer -> arr_list_differencer (* * Using some term differencer, recursively difference an array @@ -44,4 +48,7 @@ val diff_map_flat : term_differencer -> arr_differencer * Apply some differencing function * Filter the result using the supplied modifier *) -val filter_diff : ('b -> 'b) -> ('a, 'b) differencer -> ('a, 'b) differencer +val filter_diff : + ('b -> evar_map -> 'b state) -> + ('a, 'b) differencer_todo -> + ('a, 'b) differencer_todo From 5a8a680735245f7e6bf13facda773dd9ea6875a9 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 14:13:07 -0700 Subject: [PATCH 140/154] app differencers state --- .../differencing/appdifferencers.ml | 226 ++++++++++-------- 1 file changed, 122 insertions(+), 104 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index afff01f..7760413 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -17,13 +17,8 @@ open Catzooming open Debruijn open Filters open Stateutils - -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) +open Convertibility +open Kindofchange (* * Given a search function and a difference between terms, @@ -64,7 +59,7 @@ let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible en * * TODO: clean up *) -let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : Differencers.proof_differencer configurable) opts (d : goal_proof_diff) evd = +let diff_app diff_f diff_arg opts d = let (_, env) = fst (old_proof (dest_goals d)) in match map_tuple kind (proof_terms d) with | (App (f_o, args_o), App (f_n, args_n)) when Array.length args_o = Array.length args_n -> @@ -72,53 +67,69 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : let d_f = difference f_o f_n no_assumptions in let d_args = difference args_o args_n no_assumptions in (match get_change opts with - | Kindofchange.InductiveType (_, _) -> - diff_rec diff_f opts d_f evd - | Kindofchange.FixpointCase ((_, _), cut) -> - let filter_diff_cut diff d = filter_diff (fun trms _ -> filter_cut env cut trms evd) diff d evd in - let _, fs = filter_diff_cut (fun l _ -> diff_rec diff_f opts l evd) d_f in - if non_empty fs then - evd, fs - else - let d_args_rev = reverse d_args in - evd, snd (filter_diff_cut (fun ts _ -> diff_map_flat (fun ts -> diff_rec diff_arg opts ts) ts evd) d_args_rev) - | Kindofchange.ConclusionCase cut when isConstruct f_o && isConstruct f_n -> - let diff_arg o d evd = if snd (no_diff o d evd) then evd, give_up else diff_arg o d evd in + | InductiveType (_, _) -> + diff_rec diff_f opts d_f + | FixpointCase ((_, _), cut) -> + let filter_diff_cut diff d = filter_diff (filter_cut env cut) diff d in + bind + (filter_diff_cut (diff_rec diff_f opts) d_f) + (fun fs -> + if non_empty fs then + ret fs + else + filter_diff_cut + (diff_map_flat (diff_rec diff_arg opts)) + (reverse d_args)) + | ConclusionCase cut when isConstruct f_o && isConstruct f_n -> filter_diff - (fun args _ -> + (fun args -> if Option.has_some cut then let args_lambdas = List.map (reconstruct_lambda env) args in - evd, snd (filter_applies_cut env (Option.get cut) args_lambdas evd) + filter_applies_cut env (Option.get cut) args_lambdas else - evd, args) - (fun l _ -> diff_map_flat (diff_rec diff_arg (set_change opts Kindofchange.Conclusion)) l evd) + ret args) + (diff_map_flat + (diff_rec + (fun o -> + branch_state (no_diff o) (fun _ -> ret give_up) (diff_arg o)) + (set_change opts Conclusion))) d_args - evd - | Kindofchange.Hypothesis (_, _) -> + | Hypothesis (_, _) -> let old_goal = fst (old_proof d) in let new_goal = fst (new_proof d) in let (g_o, g_n) = map_tuple context_term (old_goal, new_goal) in let goal_type = mkProd (Names.Name.Anonymous, g_n, shift g_o) in let filter_goal trms evd = filter_by_type goal_type env evd trms in let filter_diff_h diff = filter_diff filter_goal diff in - let _, fs = filter_diff_h (fun l _ -> diff_rec diff_f opts l Evd.empty) d_f evd in - if non_empty fs then - evd, fs - else - evd, snd (filter_diff_h (fun d_args _ -> diff_map_flat (fun t -> diff_rec diff_arg opts t) d_args Evd.empty) d_args evd) - | Kindofchange.Conclusion | Kindofchange.Identity -> - if List.for_all2 (convertible env evd) (Array.to_list args_o) (Array.to_list args_n) then - let specialize f args = snd (specialize_using specialize_no_reduce env f args evd) in - let combine_app = combine_cartesian specialize in - let _, fs = diff_rec diff_f opts d_f evd in - let args = Array.map (fun a_o -> [a_o]) args_o in - evd, combine_app fs (combine_cartesian_append args) - else - evd, give_up + bind + (filter_diff_h (diff_rec diff_f opts) d_f) + (fun fs -> + if non_empty fs then + ret fs + else + filter_diff_h (diff_map_flat (diff_rec diff_arg opts)) d_args) + | Conclusion | Identity -> + branch_state + (fun (args_o, args_n) -> + forall2_state + (fun t1 t2 sigma -> convertible env sigma t1 t2) + (Array.to_list args_o) + (Array.to_list args_n)) + (fun (args_o, args_n) -> + let app f args = + snd (specialize_using specialize_no_reduce env f args Evd.empty) + in + let combine_app = combine_cartesian app in + let args = Array.map (fun a_o -> [a_o]) args_o in + bind + (diff_rec diff_f opts d_f) + (fun fs -> ret (combine_app fs (combine_cartesian_append args)))) + (fun _ -> ret give_up) + (args_o, args_n) | _ -> - evd, give_up) + ret give_up) | _ -> - evd, give_up + ret give_up (* * Search an application of an induction principle. @@ -126,70 +137,77 @@ let diff_app (diff_f : Differencers.proof_differencer configurable) (diff_arg : * then specialize to any final arguments. * * For changes in constructors, hypotheses, or fixpoint cases, don't specialize. + * + * TODO: Revisit when to use sigma_f once we have the recursers threading + * evar_maps correctly, before merging to master. Clean when you do that. *) -let diff_app_ind (diff_ind : Differencers.ind_proof_differencer configurable) (diff_arg : Differencers.proof_differencer configurable) opts (d : goal_proof_diff) evd = +let diff_app_ind diff_ind diff_arg opts d = let d_proofs = erase_goals d in let o = old_proof d_proofs in let n = new_proof d_proofs in let d_ind = difference (o, 0, []) (n, 0, []) (assumptions d) in - let _, d_opt = zoom_same_hypos d_ind Evd.empty in - if Option.has_some d_opt then - let d_zoom = Option.get d_opt in - let assums = assumptions d_zoom in - let (o, npms_old, args_o) = old_proof d_zoom in - let (n, npms_new, args_n) = new_proof d_zoom in - let _, f = diff_ind opts (difference (o, npms_old) (n, npms_new) assums) evd in - match get_change opts with - | (Kindofchange.InductiveType (_, _)) | (Kindofchange.Hypothesis (_, _)) -> - evd, f - | Kindofchange.FixpointCase ((_, _), cut) -> - let env = context_env (fst (old_proof d)) in - let filter_diff_cut diff d = filter_diff (fun trms _ -> filter_cut env cut trms evd) diff d evd in - if non_empty f then - evd, f - else - let diff_rec diff opts = diff_terms (fun d _ -> diff opts d evd) d opts in - let d_args = difference (Array.of_list args_o) (Array.of_list args_n) no_assumptions in - let d_args_rev = reverse d_args in - filter_diff_cut (fun d _ -> diff_map_flat (fun t sigma -> diff_rec diff_arg opts t evd) d Evd.empty) d_args_rev - | _ -> - if non_empty args_o then - let env_o = context_env (fst (old_proof d)) in - let _, (_, prop_trm_ext, _) = prop o npms_old Evd.empty in - let prop_trm = ext_term prop_trm_ext in - let rec prop_arity p = - match kind p with - | Lambda (_, _, b) -> - 1 + prop_arity b - | Prod (_, _, b) -> - 1 + prop_arity b - | _ -> - 0 - in - let arity = prop_arity prop_trm in - let specialize f args = snd (specialize_using specialize_no_reduce env_o f args evd) in - let final_args_o = Array.of_list (fst (split_at arity args_o)) in - if Kindofchange.is_identity (get_change opts) then (* TODO explain *) - evd, List.map - (fun f -> - let dummy_arg = mkRel 1 in - specialize (specialize f final_args_o) (Array.make 1 dummy_arg)) - f - else - let final_args_n = Array.of_list (fst (split_at arity args_n)) in - let d_args = difference final_args_n final_args_o no_assumptions in - let args = - Array.of_list - (snd (diff_map - (fun d_a sigma -> - let arg_n = new_proof d_a in - let apply p = ret (specialize p (Array.make 1 arg_n)) in - let diff_apply = filter_diff (map_state apply) in - diff_terms (fun ts sigma -> diff_apply (fun d _ -> diff_arg opts d evd) ts Evd.empty) d opts d_a sigma) - d_args - evd)) - in evd, combine_cartesian specialize f (combine_cartesian_append args) - else - evd, f - else - evd, give_up + bind + (zoom_same_hypos d_ind) + (fun d_opt sigma -> + if Option.has_some d_opt then + let d_zoom = Option.get d_opt in + let assums = assumptions d_zoom in + let (o, npms_old, args_o) = old_proof d_zoom in + let (n, npms_new, args_n) = new_proof d_zoom in + let sigma_f, f = diff_ind opts (difference (o, npms_old) (n, npms_new) assums) sigma in + match get_change opts with + | (InductiveType (_, _)) | (Hypothesis (_, _)) -> + sigma_f, f + | FixpointCase ((_, _), cut) -> + let env = context_env (fst (old_proof d)) in + let filter_diff_cut diff d = filter_diff (filter_cut env cut) diff d in + if non_empty f then + sigma_f, f + else + (* Note that state is relevant here; don't use sigma_f *) + let diff_rec diff opts = diff_terms (diff opts) d opts in + let d_args = difference (Array.of_list args_o) (Array.of_list args_n) no_assumptions in + let d_args_rev = reverse d_args in + filter_diff_cut (diff_map_flat (diff_rec diff_arg opts)) d_args_rev sigma + | _ -> + if non_empty args_o then + let env_o = context_env (fst (old_proof d)) in + let _, (_, prop_trm_ext, _) = prop o npms_old sigma in + let prop_trm = ext_term prop_trm_ext in + let rec prop_arity p = + match kind p with + | Lambda (_, _, b) -> + 1 + prop_arity b + | Prod (_, _, b) -> + 1 + prop_arity b + | _ -> + 0 + in + let arity = prop_arity prop_trm in + let app f args = snd (specialize_using specialize_no_reduce env_o f args Evd.empty) in + let final_args_o = Array.of_list (fst (split_at arity args_o)) in + if is_identity (get_change opts) then (* TODO explain *) + sigma, List.map + (fun f -> + let dummy_arg = mkRel 1 in + app (app f final_args_o) (Array.make 1 dummy_arg)) + f + else + let final_args_n = Array.of_list (fst (split_at arity args_n)) in + let d_args = difference final_args_n final_args_o no_assumptions in + let sigma, args = + Util.on_snd + Array.of_list + (diff_map + (fun d_a -> + let arg_n = new_proof d_a in + let apply p = ret (app p (Array.make 1 arg_n)) in + let diff_apply = filter_diff (map_state apply) in + diff_terms (diff_apply (diff_arg opts)) d opts d_a) + d_args + sigma) + in sigma, combine_cartesian app f (combine_cartesian_append args) + else + sigma_f, f + else + sigma, give_up) From 0d02a4176f4ccded2e3dd00bb711bedf286e2847 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 19:22:00 -0700 Subject: [PATCH 141/154] ind differencers state --- plugin/src/compilation/proofdiff.ml | 7 +- plugin/src/compilation/proofdiff.mli | 7 +- .../components/differencing/differencers.ml | 11 +- .../components/differencing/differencers.mli | 11 +- .../differencing/higherdifferencers.ml | 2 +- .../differencing/higherdifferencers.mli | 4 +- .../differencing/inddifferencers.ml | 142 ++++++++++-------- 7 files changed, 102 insertions(+), 82 deletions(-) diff --git a/plugin/src/compilation/proofdiff.ml b/plugin/src/compilation/proofdiff.ml index afd7d7f..abd79a5 100644 --- a/plugin/src/compilation/proofdiff.ml +++ b/plugin/src/compilation/proofdiff.ml @@ -78,8 +78,11 @@ type goal_case_diff = (arrow list) goal_diff (* --- Transformations between proof diffs --- *) (* Map a function on the old and new proofs of a diff and update assumptions *) -let map_diffs f g (d : 'a proof_diff) : 'b proof_diff = - difference (f (old_proof d)) (f (new_proof d)) (g (assumptions d)) +let map_diffs f g d = + bind + (map_tuple_state f (old_proof d, new_proof d)) + (fun (o, n) -> + bind (g (assumptions d))(fun assums -> ret (difference o n assums))) (* * Add extra information to the old and new proofs, respectively diff --git a/plugin/src/compilation/proofdiff.mli b/plugin/src/compilation/proofdiff.mli index 7917ac8..44b17c9 100644 --- a/plugin/src/compilation/proofdiff.mli +++ b/plugin/src/compilation/proofdiff.mli @@ -76,10 +76,11 @@ val goal_types : lift_goal_diff -> (types * types) (* Map a function on the old and new proofs of a diff and update assumptions *) val map_diffs : - ('a -> 'b) -> - (equal_assumptions -> equal_assumptions) -> + ('a -> evar_map -> 'b state) -> + (equal_assumptions -> evar_map -> equal_assumptions state) -> 'a proof_diff -> - 'b proof_diff + evar_map -> + 'b proof_diff state (* * Add extra information to the old and new proofs, respectively diff --git a/plugin/src/core/components/differencing/differencers.ml b/plugin/src/core/components/differencing/differencers.ml index 55d78a2..2cffaee 100644 --- a/plugin/src/core/components/differencing/differencers.ml +++ b/plugin/src/core/components/differencing/differencers.ml @@ -8,21 +8,20 @@ open Kindofchange open Evd open Stateutils -type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove when done *) -type ('a, 'b) differencer_todo = 'a proof_diff -> evar_map -> 'b state +type ('a, 'b) differencer = 'a proof_diff -> evar_map -> 'b state -type 'a candidate_differencer = ('a, candidates) differencer_todo +type 'a candidate_differencer = ('a, candidates) differencer type proof_differencer = (context_object * proof_cat) candidate_differencer type term_differencer = types candidate_differencer type ind_proof_differencer = (proof_cat * int) candidate_differencer type arr_differencer = (types array) candidate_differencer -type 'a candidate_list_differencer = ('a, candidates list) differencer_todo +type 'a candidate_list_differencer = ('a, candidates list) differencer type arr_list_differencer = (types array) candidate_list_differencer -type 'a change_detector = ('a, kind_of_change) differencer_todo +type 'a change_detector = ('a, kind_of_change) differencer type proof_change_detector = (context_object * proof_cat) change_detector -type 'a predicate_differencer = ('a, bool) differencer_todo +type 'a predicate_differencer = ('a, bool) differencer type proof_diff_predicate = (context_object * proof_cat) predicate_differencer diff --git a/plugin/src/core/components/differencing/differencers.mli b/plugin/src/core/components/differencing/differencers.mli index 46228ba..cb0a61d 100644 --- a/plugin/src/core/components/differencing/differencers.mli +++ b/plugin/src/core/components/differencing/differencers.mli @@ -8,20 +8,19 @@ open Kindofchange open Evd open Stateutils -type ('a, 'b) differencer = 'a proof_diff -> 'b (* TODO remove when done *) -type ('a, 'b) differencer_todo = 'a proof_diff -> evar_map -> 'b state +type ('a, 'b) differencer = 'a proof_diff -> evar_map -> 'b state -type 'a candidate_differencer = ('a, candidates) differencer_todo +type 'a candidate_differencer = ('a, candidates) differencer type proof_differencer = (context_object * proof_cat) candidate_differencer type term_differencer = types candidate_differencer type ind_proof_differencer = (proof_cat * int) candidate_differencer type arr_differencer = (types array) candidate_differencer -type 'a candidate_list_differencer = ('a, candidates list) differencer_todo +type 'a candidate_list_differencer = ('a, candidates list) differencer type arr_list_differencer = (types array) candidate_list_differencer -type 'a change_detector = ('a, kind_of_change) differencer_todo +type 'a change_detector = ('a, kind_of_change) differencer type proof_change_detector = (context_object * proof_cat) change_detector -type 'a predicate_differencer = ('a, bool) differencer_todo +type 'a predicate_differencer = ('a, bool) differencer type proof_diff_predicate = (context_object * proof_cat) predicate_differencer diff --git a/plugin/src/core/components/differencing/higherdifferencers.ml b/plugin/src/core/components/differencing/higherdifferencers.ml index fa1e633..7129195 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.ml +++ b/plugin/src/core/components/differencing/higherdifferencers.ml @@ -73,5 +73,5 @@ let diff_map_flat (diff : term_differencer) d_arr = * Apply some differencing function * Filter the result using the supplied modifier *) -let filter_diff filter (diff : ('a, 'b) differencer_todo) d = +let filter_diff filter (diff : ('a, 'b) differencer) d = bind (diff d) filter diff --git a/plugin/src/core/components/differencing/higherdifferencers.mli b/plugin/src/core/components/differencing/higherdifferencers.mli index 5ca67f1..96295e1 100644 --- a/plugin/src/core/components/differencing/higherdifferencers.mli +++ b/plugin/src/core/components/differencing/higherdifferencers.mli @@ -50,5 +50,5 @@ val diff_map_flat : term_differencer -> arr_differencer *) val filter_diff : ('b -> evar_map -> 'b state) -> - ('a, 'b) differencer_todo -> - ('a, 'b) differencer_todo + ('a, 'b) differencer -> + ('a, 'b) differencer diff --git a/plugin/src/core/components/differencing/inddifferencers.ml b/plugin/src/core/components/differencing/inddifferencers.ml index 670fb49..9692dc4 100644 --- a/plugin/src/core/components/differencing/inddifferencers.ml +++ b/plugin/src/core/components/differencing/inddifferencers.ml @@ -33,23 +33,27 @@ open Stateutils * To improve this, we need benchmarks for which the head is not the patch, * but another arrow is. *) -let rec diff_case abstract (diff : Differencers.proof_differencer) evd (d : goal_case_diff) : candidates = +let rec diff_case abstract diff d sigma = let d_goal = erase_proofs d in match diff_proofs d with | ((h1 :: t1), (h2 :: t2)) -> let d_t = add_to_diff d_goal t1 t2 in (try - let _, c1 = eval_proof_arrow h1 Evd.empty in - let _, c2 = eval_proof_arrow h2 Evd.empty in - let cs = abstract (snd (diff (add_to_diff d_goal c1 c2) evd)) in - if non_empty cs then - cs - else - diff_case abstract diff evd d_t + bind + (map_tuple_state eval_proof_arrow (h1, h2)) + (fun (c1, c2) -> + bind + (bind (diff (add_to_diff d_goal c1 c2)) abstract) + (fun cs sigma_h -> + if non_empty cs then + ret cs sigma_h + else + diff_case abstract diff d_t sigma)) + sigma with _ -> - diff_case abstract diff evd d_t) + diff_case abstract diff d_t sigma) | _ -> - give_up + ret give_up sigma (* * Given an ordered pair of lists of arrows to explore in the base case, @@ -66,8 +70,8 @@ let rec diff_case abstract (diff : Differencers.proof_differencer) evd (d : goal * we don't lift, but we could eventually try to apply the induction * principle for the constructor version to get a more general patch. *) -let diff_ind_case opts evd (diff : Differencers.proof_differencer) (d : goal_case_diff) : candidates = - diff_case (fun c -> snd (abstract_case opts d c evd)) diff evd d +let diff_ind_case opts diff d = + diff_case (abstract_case opts d) diff d (* * Search a case of a difference in proof categories. @@ -76,39 +80,37 @@ let diff_ind_case opts evd (diff : Differencers.proof_differencer) (d : goal_cas * This breaks it up into arrows and then searches those * in the order of the sort function. *) -let diff_sort_ind_case opts evd sort (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = +let diff_sort_ind_case opts sort diff d_old d = let o = old_proof d in let n = new_proof d in let ms_o = morphisms o in let ms_n = morphisms n in let d_ms = difference ms_o ms_n (assumptions d) in - let d_goals = - reset_case_goals - opts - d_old + bind + (bind (map_diffs - (fun (o, ms) -> (terminal o, ms)) - (fun _ -> snd (update_case_assums d_ms Evd.empty)) + (fun (o, ms) -> ret (terminal o, ms)) + (fun _ -> update_case_assums d_ms) (add_to_diff d (sort o ms_o) (sort n ms_n))) - in - if is_hypothesis (get_change opts) then - (* deal with the extra hypothesis *) - let env_o_o = context_env (fst (old_proof d_goals)) in - let env_o_n = context_env (fst (old_proof d_old)) in - let num_new_rels = nb_rel env_o_o - nb_rel env_o_n in - List.map - (unshift_by (num_new_rels - 1)) - (diff_ind_case opts evd (diff opts) d_goals) - else - diff_ind_case opts evd (diff opts) d_goals - + (fun ds -> ret (reset_case_goals opts d_old ds))) + (fun d_goals -> + if is_hypothesis (get_change opts) then + (* deal with the extra hypothesis *) + let env_o_o = context_env (fst (old_proof d_goals)) in + let env_o_n = context_env (fst (old_proof d_old)) in + let num_new_rels = nb_rel env_o_o - nb_rel env_o_n in + bind + (diff_ind_case opts (diff opts) d_goals) + (fun ds -> ret (List.map (unshift_by (num_new_rels - 1)) ds)) + else + diff_ind_case opts (diff opts) d_goals) (* * Base case: Prefer arrows later in the proof *) -let diff_base_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = +let diff_base_case opts diff d_old d = let sort _ ms = List.rev ms in - diff_sort_ind_case (set_is_ind opts false) evd sort diff d_old d + diff_sort_ind_case (set_is_ind opts false) sort diff d_old d (* * Inductive case: Prefer arrows closest to an IH, @@ -121,23 +123,28 @@ let diff_base_case opts evd (diff : Differencers.proof_differencer configurable) * For optimization, we don't bother treating the inductive case * any differently, since the IH does not change. *) -let diff_inductive_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = - let sort c ms = List.stable_sort (fun m1 m2 -> snd (closer_to_ih c (find_ihs c) m1 m2 Evd.empty)) ms in +let diff_inductive_case opts diff d_old d sigma = + let sort c ms = + (* Porting stable_sort to state is just not happening *) + List.stable_sort + (fun m1 m2 -> snd (closer_to_ih c (find_ihs c) m1 m2 sigma)) + ms + in let change = get_change opts in let opts = if is_identity change then opts else set_is_ind opts true in - diff_sort_ind_case opts evd sort diff d_old d + diff_sort_ind_case opts sort diff d_old d sigma (* * Depending on whether a proof has inductive hypotheses, difference * it treating it either like a base case (no inductive hypotheses) * or an inductive case (some inductive hypotheses). *) -let diff_base_or_inductive_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = +let diff_base_or_inductive_case opts diff d_old d = let o = old_proof d in if has_ihs o then - diff_inductive_case opts evd diff d_old d + diff_inductive_case opts diff d_old d else - diff_base_case opts evd diff d_old d + diff_base_case opts diff d_old d (* * Diff a case, then adjust the patch so it type-checks @@ -146,14 +153,15 @@ let diff_base_or_inductive_case opts evd (diff : Differencers.proof_differencer * If there is a bug here, then the offset we unshift by may not generalize * for all cases. *) -let diff_and_unshift_case opts evd (diff : Differencers.proof_differencer configurable) d_old (d : proof_cat_diff) : candidates = - List.map - (fun trm -> - if is_conclusion (get_change opts) then - unshift_by (List.length (morphisms (old_proof d))) trm - else - trm) - (diff_base_or_inductive_case opts evd diff d_old d) +let diff_and_unshift_case opts diff d_old d = + bind + (diff_base_or_inductive_case opts diff d_old d) + (map_state + (fun trm -> + if is_conclusion (get_change opts) then + ret (unshift_by (List.length (morphisms (old_proof d))) trm) + else + ret trm)) (* * Search in a diff that has been broken up into different cases. @@ -162,16 +170,19 @@ let diff_and_unshift_case opts evd (diff : Differencers.proof_differencer config * For now, we only return the first patch we find. * We may want to return more later. *) -let rec diff_ind_cases opts evd (diff : Differencers.proof_differencer configurable) d_old (ds : proof_cat_diff list) : candidates = +let rec diff_ind_cases opts diff d_old ds sigma = match ds with | d :: tl -> - let patches = diff_and_unshift_case opts evd diff d_old d in - if non_empty patches then - patches - else - diff_ind_cases opts evd diff d_old tl + bind + (diff_and_unshift_case opts diff d_old d) + (fun patches sigma_h -> + if non_empty patches then + ret patches sigma_h + else + diff_ind_cases opts diff d_old tl sigma) + sigma | [] -> - [] + ret [] sigma (* --- Top-level --- *) @@ -184,20 +195,27 @@ let rec diff_ind_cases opts evd (diff : Differencers.proof_differencer configura * This does not yet handle the case when the inductive parameters * are lists of different lengths, or where there is a change in hypothesis. *) -let diff_inductive (diff : Differencers.proof_differencer configurable) d_old opts (d : (proof_cat * int) proof_diff) evd = +let diff_inductive diff d_old opts (d : (proof_cat * int) proof_diff) = let (o, nparams_o) = old_proof d in let (n, nparams_n) = new_proof d in if not (nparams_o = nparams_n) then - Evd.empty, give_up + ret give_up else + let sort c = + bind + (bind (split c) (map_state expand_constr)) + (fun cs -> ret (base_cases_first cs)) + in zoom_map - (fun d sigma -> - let sort c = base_cases_first (List.map (fun c -> snd (expand_constr c Evd.empty)) (snd (split c Evd.empty))) in - let d_sorted = map_diffs sort id d in - let ds = dest_cases d_sorted in - map_state (fun d -> ret (unshift_by nparams_o d)) (diff_ind_cases opts evd diff d_old ds) Evd.empty) + (fun d -> + bind + (map_diffs sort ret d) + (fun d_sorted -> + let ds = dest_cases d_sorted in + bind + (diff_ind_cases opts diff d_old ds) + (map_state (fun d -> ret (unshift_by nparams_o d))))) [] ret (intro_params nparams_o) (difference o n (assumptions d)) - Evd.empty From 0bef0c259f5779c72c4b441603ed5c1ca43e9328 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 21:00:22 -0700 Subject: [PATCH 142/154] fix differencers with state --- .../differencing/fixdifferencers.ml | 135 +++++++++++------- 1 file changed, 80 insertions(+), 55 deletions(-) diff --git a/plugin/src/core/components/differencing/fixdifferencers.ml b/plugin/src/core/components/differencing/fixdifferencers.ml index f54577d..9569e3f 100644 --- a/plugin/src/core/components/differencing/fixdifferencers.ml +++ b/plugin/src/core/components/differencing/fixdifferencers.ml @@ -13,13 +13,8 @@ open Evd open Zooming open Contextutils open Envutils - -(* --- TODO for backwards compatibility during refactor, fix w/ evar_map updates --- *) - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) +open Convertibility +open Stateutils (* --- Cases --- *) @@ -35,55 +30,76 @@ let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible en * just is super preliminary. * After the prototype we should model fixpoints better. *) -let rec get_goal_fix env evd (d : types proof_diff) : candidates = +let rec get_goal_fix env d = let old_term = old_proof d in let new_term = new_proof d in let assums = assumptions d in if equal old_term new_term then - give_up + ret give_up else + let rec get_goal_reduced d = + let reduce_hd t sigma = reduce_unfold_whd env sigma t in + bind + (map_tuple_state reduce_hd (old_proof d, new_proof d)) + (fun (red_old, red_new) -> + match map_tuple kind (red_old, red_new) with + | (App (f1, args1), App (f2, args2)) when equal f1 f2 -> + let d_args = difference args1 args2 no_assumptions in + diff_map_flat get_goal_reduced d_args + | _ when not (equal red_old red_new) -> + let g = mkProd (Names.Name.Anonymous, red_old, shift red_new) in + bind (fun sigma -> reduce_unfold env sigma g) (fun l -> ret [l]) + | _ -> + ret give_up) + in match map_tuple kind (old_term, new_term) with - | (Lambda (n1, t1, b1), Lambda (_, t2, b2)) when convertible env evd t1 t2 -> - List.map - (fun c -> mkProd (n1, t1, c)) - (get_goal_fix (push_rel CRD.(LocalAssum(n1, t1)) env) evd (difference b1 b2 assums)) + | (Lambda (n1, t1, b1), Lambda (_, t2, b2)) -> + branch_state + (fun (t1, t2) sigma -> convertible env sigma t1 t2) + (fun (t1, t2) -> + bind + (get_goal_fix (push_local (n1, t1) env) (difference b1 b2 assums)) + (map_state (fun c -> ret (mkProd (n1, t1, c))))) + (fun _ -> + get_goal_reduced (difference old_term new_term no_assumptions)) + (t1, t2) | _ -> - let reduce_hd = reduce_unfold_whd env evd in - let rec get_goal_reduced d : candidates = - let _, red_old = reduce_hd (old_proof d) in - let _, red_new = reduce_hd (new_proof d) in - match map_tuple kind (red_old, red_new) with - | (App (f1, args1), App (f2, args2)) when equal f1 f2 -> - let d_args = difference args1 args2 no_assumptions in - snd (diff_map_flat (fun t sigma -> sigma, get_goal_reduced t) d_args Evd.empty) - | _ when not (equal red_old red_new) -> - [snd (reduce_unfold env evd (mkProd (Names.Name.Anonymous, red_old, shift red_new)))] - | _ -> - give_up - in get_goal_reduced (difference old_term new_term no_assumptions) + get_goal_reduced (difference old_term new_term no_assumptions) (* Same as the above, but at the top-level for the fixpoint case *) -let rec diff_fix_case env evd (d : types proof_diff) : candidates = +let rec diff_fix_case env d = let old_term = old_proof d in let new_term = new_proof d in let assums = assumptions d in - let conv = convertible env evd in + let diff_case (ct1, m1, bs1) (ct2, m2, bs2) = + branch_state + (fun (m1, m2) sigma -> convertible env sigma m1 m2) + (fun (m1, m2) -> + if Array.length bs1 = Array.length bs2 then + let env_m = push_local (Names.Name.Anonymous, m1) env in + let diff_bs = diff_map_flat (get_goal_fix env_m) in + bind + (map_tuple_state + diff_bs + (difference bs1 bs2 assums, difference bs2 bs1 assums)) + (fun (cs1, cs2) -> ret (unshift_all (List.append cs1 cs2))) + else + ret give_up) + (fun _ -> ret give_up) + (m1, m2) + in match map_tuple kind (old_term, new_term) with - | (Lambda (n1, t1, b1), Lambda (_, t2, b2)) when conv t1 t2 -> - diff_fix_case (push_rel CRD.(LocalAssum(n1, t1)) env) evd (difference b1 b2 assums) - | (Case (_, ct1, m1, bs1), Case (_, ct2, m2, bs2)) when conv m1 m2 -> - if Array.length bs1 = Array.length bs2 then - let env_m = push_rel CRD.(LocalAssum(Names.Name.Anonymous, m1)) env in - let diff_bs l = snd (diff_map_flat (fun t sigma -> sigma, get_goal_fix env_m evd t) l evd) in - List.map - unshift - (List.append - (diff_bs (difference bs1 bs2 assums)) - (diff_bs (difference bs2 bs1 assums))) - else - give_up + | (Lambda (n1, t1, b1), Lambda (_, t2, b2)) -> + branch_state + (fun (t1, t2) sigma -> convertible env sigma t1 t2) + (fun (t1, t2) -> + diff_fix_case (push_local (n1, t1) env) (difference b1 b2 assums)) + (fun _ -> ret give_up) + (t1, t2) + | (Case (_, ct1, m1, bs1), Case (_, ct2, m2, bs2)) -> + diff_case (ct1, m1, bs1) (ct2, m2, bs2) | _ -> - give_up + ret give_up (* --- Top-level --- *) @@ -93,23 +109,32 @@ let rec diff_fix_case env evd (d : types proof_diff) : candidates = * This operates at the term level, since compilation currently * doesn't model fixpoints. *) -let diff_fix_cases env (d : types proof_diff) evd : candidates Stateutils.state = +let diff_fix_cases env (d : types proof_diff) = let old_term = unwrap_definition env (old_proof d) in let new_term = unwrap_definition env (new_proof d) in let assums = assumptions d in match map_tuple kind (old_term, new_term) with | (Fix ((_, i), (nso, tso, dso)), Fix ((_, j), (_, tsn, dsn))) when i = j -> - if List.for_all2 (convertible env evd) (Array.to_list tso) (Array.to_list tsn) then - let env_fix = push_rel_context (bindings_for_fix nso tso) env in - let d_ds = difference dso dsn assums in - let ds = snd (diff_map_flat (fun t sigma -> sigma, diff_fix_case env_fix evd t) d_ds evd) in - let lambdas = List.map (reconstruct_lambda env_fix) ds in - let apps = - List.map - (fun t -> mkApp (t, Array.make 1 new_term)) - lambdas - in evd, unique equal (snd (reduce_all reduce_term env evd apps)) - else - failwith "Cannot infer goals for generalizing change in definition" + branch_state + (fun (tso, tsn) -> + forall2_state + (fun t1 t2 sigma -> convertible env sigma t1 t2) + (Array.to_list tso) + (Array.to_list tsn)) + (fun _ -> + let env_fix = push_rel_context (bindings_for_fix nso tso) env in + let d_ds = difference dso dsn assums in + bind + (diff_map_flat (diff_fix_case env_fix) d_ds) + (fun ds -> + let fs = List.map (reconstruct_lambda env_fix) ds in + let args = Array.make 1 new_term in + let apps = List.map (fun f -> mkApp (f, args)) fs in + bind + (fun sigma -> reduce_all reduce_term env sigma apps) + (fun red_apps -> ret (unique equal red_apps)))) + (fun _ _ -> + failwith "Cannot infer goals for generalizing change in definition") + (tso, tsn) | _ -> failwith "Not a fixpoint" From 55fed9ced82997e90705a40a903f23c75849d972 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 21:51:31 -0700 Subject: [PATCH 143/154] differencing state --- plugin/src/configuration/searchopts.ml | 2 +- plugin/src/configuration/searchopts.mli | 2 +- .../components/differencing/differencing.ml | 87 ++++++++++--------- 3 files changed, 48 insertions(+), 43 deletions(-) diff --git a/plugin/src/configuration/searchopts.ml b/plugin/src/configuration/searchopts.ml index 948c0af..a55ad3b 100644 --- a/plugin/src/configuration/searchopts.ml +++ b/plugin/src/configuration/searchopts.ml @@ -286,7 +286,7 @@ let update_terms_goals opts t_o t_n d = (* Convert search to a search_function for zooming *) let to_search_function search opts d = (fun d' -> - bind (update_search_goals opts d d') (fun d -> ret (search opts d))) + bind (update_search_goals opts d d') (search opts)) (* * Check if a term applies the inductive hypothesis diff --git a/plugin/src/configuration/searchopts.mli b/plugin/src/configuration/searchopts.mli index 0823508..344ce34 100644 --- a/plugin/src/configuration/searchopts.mli +++ b/plugin/src/configuration/searchopts.mli @@ -72,7 +72,7 @@ val update_terms_goals : * can be used by zooming. *) val to_search_function : - ((goal_proof_diff -> candidates) configurable) -> + ((goal_proof_diff -> evar_map -> candidates state) configurable) -> (goal_proof_diff -> search_function) configurable (* diff --git a/plugin/src/core/components/differencing/differencing.ml b/plugin/src/core/components/differencing/differencing.ml index 0b65313..08039b4 100644 --- a/plugin/src/core/components/differencing/differencing.ml +++ b/plugin/src/core/components/differencing/differencing.ml @@ -15,6 +15,7 @@ open Term open Evd open Utilities open Constr +open Stateutils (* --- Debugging --- *) @@ -82,51 +83,55 @@ let debug_search (d : goal_proof_diff) : unit = * 6c. When 6b doesn't produce anything, try reducing the diff and calling * recursively. (Support for this is preliminary.) *) -let rec diff (opts : options) (evd : evar_map) (d : goal_proof_diff) : candidates = - let diff_o = diff in - let diff opts d evd = evd, diff opts evd d in - let d = snd (reduce_letin (snd (reduce_casts d Evd.empty)) Evd.empty) in - if snd (no_diff opts d evd) then - (*1*) snd (identity_candidates d (Evd.from_env (Proofcatterms.context_env (fst (new_proof d))))) - else if induct_over_same_h (same_h opts) d then - snd - (try_chain_diffs - [(diff_app_ind (diff_inductive diff d) diff opts); (* 2a *) - (find_difference opts)] (* 2b *) - d - evd) - else if applies_ih opts d then - (*3*) snd (diff_app diff diff opts (snd (reduce_trim_ihs d Evd.empty)) evd) - else - match map_tuple kind (proof_terms d) with - | (Lambda (n_o, t_o, b_o), Lambda (_, t_n, b_n)) -> - let change = get_change opts in - let ind = is_ind opts in - let opts_hypos = if is_identity change then set_change opts Conclusion else opts in - if snd (no_diff opts_hypos (snd (eval_with_terms t_o t_n d Evd.empty)) evd) then - (*4*) snd (zoom_wrap_lambda (to_search_function (fun opts -> diff_o opts evd) opts d) n_o t_o d Evd.empty) - else if ind || not (is_conclusion change || is_identity change) then - (*5*) snd (zoom_unshift (to_search_function (fun opts -> diff_o opts evd) opts d) d Evd.empty) - else - give_up - | _ -> - if is_app opts d then - snd - (try_chain_diffs - [(find_difference opts); (* 6a *) - (diff_app diff diff opts); (* 6b *) - (diff_reduced (diff opts))] (* 6c *) - d - evd) - else - give_up - +let rec diff (opts : options) (d : goal_proof_diff) = + bind + (bind (reduce_casts d) reduce_letin) + (branch_state + (no_diff opts) + identity_candidates (* 1 *) + (fun d -> + if induct_over_same_h (same_h opts) d then + try_chain_diffs + [(diff_app_ind (diff_inductive diff d) diff opts); (* 2a *) + (find_difference opts)] (* 2b *) + d + else if applies_ih opts d then + bind (reduce_trim_ihs d) (diff_app diff diff opts) (* 3 *) + else + match map_tuple kind (proof_terms d) with + | (Lambda (n_o, t_o, b_o), Lambda (_, t_n, b_n)) -> + let change = get_change opts in + let ind = is_ind opts in + let is_id = is_identity change in + let search_body = to_search_function diff opts d in + bind + (eval_with_terms t_o t_n d) + (branch_state + (no_diff + (if is_id then set_change opts Conclusion else opts)) + (fun _ -> zoom_wrap_lambda search_body n_o t_o d) (* 4 *) + (fun _ -> + let is_concl = is_conclusion change in + if ind || not (is_concl || is_id) then + zoom_unshift search_body d (* 5 *) + else + ret give_up)) + | _ -> + if is_app opts d then + try_chain_diffs + [(find_difference opts); (* 6a *) + (diff_app diff diff opts); (* 6b *) + (diff_reduced (diff opts))] (* 6c *) + d + else + ret give_up)) + (* --- Top-level differencer --- *) (* Given a configuration, return the appropriate differencer *) let get_differencer (opts : options) = let should_reduce = is_inductive_type (get_change opts) in if should_reduce then - (fun d evd -> evd, diff opts evd (snd (reduce_diff reduce_term d Evd.empty))) + (fun d -> bind (reduce_diff reduce_term d) (diff opts)) else - (fun d evd -> evd, diff opts evd d) + diff opts From 8962be006ff646a1d7a540857d5bf3f8cfda64e6 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 22:07:37 -0700 Subject: [PATCH 144/154] search state --- plugin/src/core/procedures/search.ml | 65 ++++++++++++++------------- plugin/src/core/procedures/search.mli | 4 +- plugin/src/patcher.ml4 | 4 +- 3 files changed, 40 insertions(+), 33 deletions(-) diff --git a/plugin/src/core/procedures/search.ml b/plugin/src/core/procedures/search.ml index ec25c8a..8374ef8 100644 --- a/plugin/src/core/procedures/search.ml +++ b/plugin/src/core/procedures/search.ml @@ -41,35 +41,40 @@ open Stateutils * not a huge deal, but this gives us a weaker idea of when to apply these * patches, which will matter eventually. *) -let return_patch opts env evd (patches : types list) : types = +let return_patch opts env (patches : types list) = + let ret_patch cs = ret (List.hd cs) (* TODO better failure when empty *) in + let reduce_patches reducer sigma = reduce_all reducer env sigma patches in match get_change opts with | FixpointCase ((old_type, new_type), cut) -> let body_reducer = specialize_in (get_app cut) specialize_term in - let reduction_condition en evd tr = has_cut_type_strict_sym en cut tr evd in - let reducer = reduce_body_if reduction_condition body_reducer in - let _, specialized = reduce_all reducer env evd patches in - let specialized_fs = List.map (fun t -> snd (factor_term env t evd)) specialized in - let specialized_fs_terms = flat_map reconstruct_factors specialized_fs in - let generalized = - flat_map - (fun ss -> snd (abstract_with_strategies ss evd)) - (snd (configure_fixpoint_cases - env - (snd (diff_fix_cases env (difference old_type new_type no_assumptions) evd)) - specialized_fs_terms - evd)) - in List.hd generalized (* TODO better failure when none found *) + let do_reduce env sigma tr = has_cut_type_strict_sym env cut tr sigma in + let reducer = reduce_body_if do_reduce body_reducer in + bind + (bind + (bind (reduce_patches reducer) (map_state (factor_term env))) + (fun fs -> ret (flat_map reconstruct_factors fs))) + (fun fs -> + bind + (bind + (diff_fix_cases env (difference old_type new_type no_assumptions)) + (fun cs -> + bind + (configure_fixpoint_cases env cs fs) + (flat_map_state abstract_with_strategies))) + ret_patch) | ConclusionCase (Some cut) -> - let _, patches = reduce_all remove_unused_hypos env evd patches in - let evd, strategies = configure_cut_args env cut patches evd in - let generalized = snd (abstract_with_strategies strategies evd) in - List.hd generalized (* TODO better failure when none found *) + bind + (bind + (bind + (reduce_patches remove_unused_hypos) + (configure_cut_args env cut)) + abstract_with_strategies) + ret_patch | Hypothesis (_, _) -> - let _, patches = reduce_all remove_unused_hypos env evd patches in - List.hd patches + bind (reduce_patches remove_unused_hypos) ret_patch | _ -> Printf.printf "%s\n" "SUCCESS"; - List.hd patches + ret_patch patches (* * The top-level search procedure! @@ -77,29 +82,29 @@ let return_patch opts env evd (patches : types list) : types = * Search in one direction, and if we fail try the other direction. * If we find patches, return the head for now, since any patch will do. *) -let search_for_patch evd (default : types) (opts : options) (d : goal_proof_diff) : types = +let search_for_patch (default : types) (opts : options) (d : goal_proof_diff) sigma = Printf.printf "%s\n\n" "----"; let change = get_change opts in let start_backwards = is_fixpoint_case change || is_hypothesis change in let d = if start_backwards then reverse d else d in (* explain *) - let d = snd (update_search_goals opts d (erase_goals d) Evd.empty) in + let sigma, d = update_search_goals opts d (erase_goals d) sigma in let diff = get_differencer opts in - let _, patches = diff d evd in + let sigma_non_rev, patches = diff d sigma in let ((_, env), _) = old_proof (dest_goals d) in if non_empty patches then - return_patch opts env evd patches + return_patch opts env patches sigma_non_rev else - let _, rev_patches = diff (reverse d) evd in + let sigma_rev, rev_patches = diff (reverse d) sigma in Printf.printf "%s\n" "searched backwards"; Printf.printf "inverting %d candidates\n" (List.length rev_patches); - let inverted = snd (invert_terms invert_factor env rev_patches evd) in + let sigma_inv, inverted = invert_terms invert_factor env rev_patches sigma_rev in if non_empty inverted then - return_patch opts env evd inverted + return_patch opts env inverted sigma_inv else match change with | Conclusion | (Hypothesis (_, _)) -> let patch = default in Printf.printf "%s\n" "FAILURE"; - patch + sigma, patch | _ -> failwith "Could not find patch" diff --git a/plugin/src/core/procedures/search.mli b/plugin/src/core/procedures/search.mli index fb96fad..abb3db9 100644 --- a/plugin/src/core/procedures/search.mli +++ b/plugin/src/core/procedures/search.mli @@ -4,11 +4,13 @@ open Constr open Proofdiff open Searchopts open Evd +open Stateutils (* * Search for a patch given a default patch and a difference in proof cats * Return the default patch if we cannot find a patch * Otherwise, return any patch we can find *) -val search_for_patch : evar_map -> types -> options -> goal_proof_diff -> types +val search_for_patch : + types -> options -> goal_proof_diff -> evar_map -> types state diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index a3412cc..524a643 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -147,7 +147,7 @@ let patch_proof n d_old d_new cut = let try_invert = not (is_conclusion change || is_hypothesis change) in patch env evm n try_invert () (fun env evm _ -> - search_for_patch evm old_term opts d) + snd (search_for_patch old_term opts d evm)) (* * Command functionality for optimizing proofs. @@ -166,7 +166,7 @@ let optimize_proof n d = let (d, opts) = configure_optimize trm in patch env evm n false () (fun env evm _ -> - search_for_patch evm trm opts d) + snd (search_for_patch trm opts d evm)) (* * The Patch Theorem command functionality From 1d242f67e108105059e6225d55b59cc49242d41b Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 22:46:32 -0700 Subject: [PATCH 145/154] theorem state --- plugin/src/core/procedures/theorem.ml | 113 ++++++++++--------------- plugin/src/core/procedures/theorem.mli | 3 +- plugin/src/patcher.ml4 | 2 +- plugin/test.sh | 1 + 4 files changed, 49 insertions(+), 70 deletions(-) diff --git a/plugin/src/core/procedures/theorem.ml b/plugin/src/core/procedures/theorem.ml index e32c96d..7ca544a 100644 --- a/plugin/src/core/procedures/theorem.ml +++ b/plugin/src/core/procedures/theorem.ml @@ -9,44 +9,11 @@ open Specialization open Evd open Zooming open Contextutils - -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = - let jmt = Typeops.infer env trm in - j_type jmt - -let convertible env sigma t1 t2 = snd (Convertibility.convertible env sigma t1 t2) -let types_convertible env sigma t1 t2 = snd (Convertibility.types_convertible env sigma t1 t2) - -(* --- End TODO --- *) - -(* - * Zoom all the way into a lambda term - * - * TODO common with reversal, factor that out - *) -let rec zoom_lambda_term (env : env) (trm : types) : env * types = - match kind trm with - | Lambda (n, t, b) -> - zoom_lambda_term (push_rel CRD.(LocalAssum(n, t)) env) b - | _ -> - (env, trm) - -(* - * Zoom all the way into a product type - *) -let rec zoom_product_type (env : env) (typ : types) : env * types = - match kind typ with - | Prod (n, t, b) -> - zoom_product_type (push_rel CRD.(LocalAssum(n, t)) env) b - | _ -> - (env, typ) +open Inference +open Convertibility +open Envutils +open Zooming +open Stateutils (* * Get the arguments to a function within a term @@ -54,32 +21,41 @@ let rec zoom_product_type (env : env) (typ : types) : env * types = * Assumes the function is a constant * Dumb for now *) -let rec args_to env evd (f : types) (trm : types) : env * (types array) = +let rec args_to env (f : types) (trm : types) sigma = let nonempty (_, a) = Array.length a > 0 in match kind trm with | Lambda (n, t, b) -> - args_to (push_rel CRD.(LocalAssum(n,t)) env) evd f b + args_to (push_local (n, t) env) f b sigma | App (g, args) -> - if convertible env evd g f then - (env, args) - else - let envs_args = List.map (args_to env evd f) (Array.to_list args) in - if List.exists nonempty envs_args then - List.find nonempty envs_args - else - args_to env evd f g + branch_state + (fun g sigma -> convertible env sigma g f) + (fun _ -> ret (env, args)) + (fun g sigma -> + bind + (map_state (args_to env f) (Array.to_list args)) + (fun envs_args sigma_args -> + if List.exists nonempty envs_args then + sigma_args, List.find nonempty envs_args + else + args_to env f g sigma) + sigma) + g + sigma | LetIn (n, trm, typ, e) -> - args_to (push_rel CRD.(LocalDef(n, e, typ)) env) evd f e + args_to (push_rel CRD.(LocalDef(n, e, typ)) env) f e sigma | Case (ci, ct, m, bs) -> - let bs_args = List.map (args_to env evd f) (Array.to_list bs) in - if List.exists nonempty bs_args then - List.find nonempty bs_args - else - (env, Array.of_list []) + bind + (map_state (args_to env f) (Array.to_list bs)) + (fun bs_args sigma_bs -> + if List.exists nonempty bs_args then + sigma_bs, List.find nonempty bs_args + else + sigma, (env, Array.of_list [])) + sigma | Cast (c, k, t) -> - args_to env evd f c + args_to env f c sigma | _ -> (* not yet implemented *) - (env, Array.of_list []) + sigma, (env, Array.of_list []) (* * Subtitute a term into a simple theorem @@ -94,31 +70,32 @@ let rec args_to env evd (f : types) (trm : types) : env * (types array) = * And doesn't do anything fancy yet like actually look at the terms. * It's a pretty naive heuristic to get this started. *) -let update_theorem env evd (src : types) (dst : types) (trm : types) : types = +let update_theorem env (src : types) (dst : types) (trm : types) sigma = assert (isConst src && isConst dst); let (env, trm) = zoom_lambda_term env trm in - let _, trm = reduce_term env evd trm in - let (env_args, args) = args_to env evd src trm in - let specialize f args = snd (specialize_using specialize_no_reduce env_args f args evd) in - let src_typ = infer_type env_args evd (specialize src args) in - let dst_typ = infer_type env_args evd (specialize dst args) in + let sigma, trm = reduce_term env sigma trm in + let sigma, (env_args, args) = args_to env src trm sigma in + let specialize f args = specialize_using specialize_no_reduce env_args f args in + let sigma, src_typ = bind (specialize src args) (fun t sigma -> infer_type env_args sigma t) sigma in + let sigma, dst_typ = bind (specialize dst args) (fun t sigma -> infer_type env_args sigma t) sigma in let (env_s, src_concl) = zoom_product_type env_args src_typ in let (env_d, dst_concl) = zoom_product_type env_args dst_typ in let num_hs = nb_rel env in let num_src_hs = nb_rel env_s - num_hs in let num_dst_hs = nb_rel env_d - num_hs in - let patch = snd (all_conv_substs env evd (src, dst) trm) in (* TODO evar_map *) - let patch_dep = + let sigma, patch = all_conv_substs env sigma (src, dst) trm in (* TODO evar_map *) + let sigma, patch_dep = if num_src_hs = num_dst_hs then let patch = shift_by num_src_hs patch in - unshift_by num_src_hs (snd (all_conv_substs env_s evd (src_concl, dst_concl) patch)) (* TODO evar_map *) + let sigma, subbed = all_conv_substs env_s sigma (src_concl, dst_concl) patch in + sigma, unshift_by num_src_hs subbed else - patch + sigma, patch in let patch_lambda = reconstruct_lambda env patch_dep in try - let _ = infer_type env evd patch_lambda in - patch_lambda + let sigma, _ = infer_type env sigma patch_lambda in + sigma, patch_lambda with _ -> failwith "Patched Theorem is not well-typed" diff --git a/plugin/src/core/procedures/theorem.mli b/plugin/src/core/procedures/theorem.mli index f4148bf..6f7b46d 100644 --- a/plugin/src/core/procedures/theorem.mli +++ b/plugin/src/core/procedures/theorem.mli @@ -3,9 +3,10 @@ open Constr open Environ open Evd +open Stateutils (* * Subtitute a term into a simple theorem * Try to update dependent types appropriately *) -val update_theorem : env -> evar_map -> types -> types -> types -> types +val update_theorem : env -> types -> types -> types -> evar_map -> types state diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 524a643..2dcf079 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -183,7 +183,7 @@ let patch_theorem n d_old d_new t = (fun env evm t -> let evm, theorem = intern env evm t in let t_trm = lookup_definition env theorem in - update_theorem env evm old_term new_term t_trm) + snd (update_theorem env old_term new_term t_trm evm)) (* Invert a term *) let invert n trm : unit = diff --git a/plugin/test.sh b/plugin/test.sh index 3908e63..77c8ce8 100755 --- a/plugin/test.sh +++ b/plugin/test.sh @@ -6,3 +6,4 @@ coqc coq/divide.v coqc coq/Induction.v coqc coq/IntegersNew.v coqc coq/Optimization.v +coqc coq/Theorem.v From 7bd3d34bbbd66f883406c8a552442ececb70e213 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 23:19:29 -0700 Subject: [PATCH 146/154] frontend evar_maps! --- plugin/src/patcher.ml4 | 160 ++++++++++++++++++++--------------------- 1 file changed, 77 insertions(+), 83 deletions(-) diff --git a/plugin/src/patcher.ml4 b/plugin/src/patcher.ml4 index 2dcf079..4de08dd 100644 --- a/plugin/src/patcher.ml4 +++ b/plugin/src/patcher.ml4 @@ -26,22 +26,11 @@ open Utilities open Zooming open Defutils open Envutils +open Stateutils +open Inference module Globmap = Globnames.Refmap -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types = - let jmt = Typeops.infer env trm in - j_type jmt - -(* --- End TODO --- *) - (* * Plugin for patching Coq proofs given a change. * @@ -71,62 +60,64 @@ let _ = Goptions.declare_bool_option { (* --- Auxiliary functionality for top-level functions --- *) (* Intern terms corresponding to two definitions *) -let intern_defs d1 d2 : evar_map * types * types = - let (evm, env) = Pfedit.get_current_context() in - let evm, d1 = intern env evm d1 in - let evm, d2 = intern env evm d2 in - (evm, unwrap_definition env d1, unwrap_definition env d2) +let intern_defs env d1 d2 = + bind + (map_tuple_state (fun t sigma -> intern env sigma t) (d1, d2)) + (fun (d1, d2) -> + ret (unwrap_definition env d1, unwrap_definition env d2)) (* Initialize diff & search configuration *) -let configure trm1 trm2 cut : goal_proof_diff * options = - let (evm, env) = Pfedit.get_current_context() in - let cut_term = Option.map (intern env evm) cut in - let lemma = Option.map (fun evm, t -> build_cut_lemma env t) cut_term in - let _, c1 = eval_proof env trm1 Evd.empty in - let _, c2 = eval_proof env trm2 Evd.empty in - let d = add_goals (difference c1 c2 no_assumptions) in - let _, change = find_kind_of_change lemma d evm in - (d, configure_search d change lemma) +let configure env trm1 trm2 cut sigma = + let cut_term = Option.map (intern env sigma) cut in + let lemma = Option.map (fun (_, t) -> build_cut_lemma env t) cut_term in + bind + (map_tuple_state (eval_proof env) (trm1, trm2)) + (fun (c1, c2) -> + let d = add_goals (difference c1 c2 no_assumptions) in + bind + (find_kind_of_change lemma d) + (fun change -> ret (d, configure_search d change lemma))) + sigma (* Initialize diff & search configuration for optimization *) -let configure_optimize trm : goal_proof_diff * options = - let (evm, env) = Pfedit.get_current_context () in - let _, c = eval_proof env trm Evd.empty in - let d = add_goals (difference c c no_assumptions) in - let change = Identity in - (d, configure_search d change None) +let configure_optimize env trm = + bind + (eval_proof env trm) + (fun c -> + let d = add_goals (difference c c no_assumptions) in + ret (d, configure_search d Identity None)) (* Common inversion functionality *) -let invert_patch n env evm patch = - let evm, inverted = invert_terms invert_factor env [patch] evm in +let invert_patch n env patch sigma = + let sigma, inverted = invert_terms invert_factor env [patch] sigma in try let patch_inv = List.hd inverted in - let _ = infer_type env evm patch_inv in - ignore (define_term n evm patch_inv false); + let sigma, _ = infer_type env sigma patch_inv in + ignore (define_term n sigma patch_inv false); let n_string = Id.to_string n in if !opt_printpatches then - print_patch env evm n_string patch_inv + print_patch env sigma n_string patch_inv else Printf.printf "Defined %s\n" (Id.to_string n) with _ -> failwith "Could not find a well-typed inverted term" (* Common patch command functionality *) -let patch env evm n try_invert a search = +let patch env n try_invert a search sigma = let reduce = try_reduce reduce_remove_identities in - let patch_to_red = search env evm a in - let _, patch = reduce env evm patch_to_red in + let sigma, patch_to_red = search env a sigma in + let sigma, patch = reduce env sigma patch_to_red in let prefix = Id.to_string n in - ignore (define_term n evm patch false); + ignore (define_term n sigma patch false); (if !opt_printpatches then - print_patch env evm prefix patch + print_patch env sigma prefix patch else Printf.printf "Defined %s\n" prefix); if try_invert then try let inv_n_string = String.concat "_" [prefix; "inv"] in let inv_n = Id.of_string inv_n_string in - invert_patch inv_n env evm patch + invert_patch inv_n env patch sigma with _ -> () else @@ -140,14 +131,13 @@ let patch env evm n try_invert a search = * The latter two just pass extra guidance for now *) let patch_proof n d_old d_new cut = - let (evm, env) = Pfedit.get_current_context () in - let (evm, old_term, new_term) = intern_defs d_old d_new in - let (d, opts) = configure old_term new_term cut in + let (sigma, env) = Pfedit.get_current_context () in + let sigma, (old_term, new_term) = intern_defs env d_old d_new sigma in + let sigma, (d, opts) = configure env old_term new_term cut sigma in let change = get_change opts in let try_invert = not (is_conclusion change || is_hypothesis change) in - patch env evm n try_invert () - (fun env evm _ -> - snd (search_for_patch old_term opts d evm)) + let search _ _ = search_for_patch old_term opts d in + patch env n try_invert () search sigma (* * Command functionality for optimizing proofs. @@ -160,13 +150,12 @@ let patch_proof n d_old d_new cut = * this as a special configuration, and pass in the same term twice. *) let optimize_proof n d = - let (evm, env) = Pfedit.get_current_context () in - let evm, def = intern env evm d in + let (sigma, env) = Pfedit.get_current_context () in + let sigma, def = intern env sigma d in let trm = unwrap_definition env def in - let (d, opts) = configure_optimize trm in - patch env evm n false () - (fun env evm _ -> - snd (search_for_patch trm opts d evm)) + let sigma, (d, opts) = configure_optimize env trm sigma in + let search _ _ = search_for_patch trm opts d in + patch env n false () search sigma (* * The Patch Theorem command functionality @@ -176,67 +165,72 @@ let optimize_proof n d = * It just might be useful in the future, so feel free to play with it *) let patch_theorem n d_old d_new t = - let (evm, env) = Pfedit.get_current_context() in - let evm, old_term = intern env evm d_old in - let evm, new_term = intern env evm d_new in - patch env evm n false t - (fun env evm t -> - let evm, theorem = intern env evm t in - let t_trm = lookup_definition env theorem in - snd (update_theorem env old_term new_term t_trm evm)) + let (sigma, env) = Pfedit.get_current_context() in + let sigma, old_term = intern env sigma d_old in + let sigma, new_term = intern env sigma d_new in + let search env t sigma = + let sigma, theorem = intern env sigma t in + let t_trm = lookup_definition env theorem in + update_theorem env old_term new_term t_trm sigma + in patch env n false t search sigma (* Invert a term *) let invert n trm : unit = - let (evm, env) = Pfedit.get_current_context() in - let evm, def = intern env evm trm in + let (sigma, env) = Pfedit.get_current_context () in + let sigma, def = intern env sigma trm in let body = lookup_definition env def in - invert_patch n env evm body + invert_patch n env body sigma (* Specialize a term *) let specialize n trm : unit = - let (evm, env) = Pfedit.get_current_context() in + let (sigma, env) = Pfedit.get_current_context () in let reducer = specialize_body specialize_term in - let evm, def = intern env evm trm in - let _, specialized = reducer env evm def in - ignore (define_term n evm specialized false) + let sigma, def = intern env sigma trm in + let sigma, specialized = reducer env sigma def in + ignore (define_term n sigma specialized false) (* Abstract a term by a function or arguments *) let abstract n trm goal : unit = - let (evm, env) = Pfedit.get_current_context() in - let evm, def = intern env evm trm in + let (sigma, env) = Pfedit.get_current_context () in + let sigma, def = intern env sigma trm in let c = lookup_definition env def in - let evm, goal_def = intern env evm goal in + let sigma, goal_def = intern env sigma goal in let goal_type = unwrap_definition env goal_def in - let evm, config = configure_from_goal env goal_type c evm in - let abstracted = snd (abstract_with_strategies config evm) in + let sigma, config = configure_from_goal env goal_type c sigma in + let sigma, abstracted = abstract_with_strategies config sigma in if List.length abstracted > 0 then try - ignore (define_term n evm (List.hd abstracted) false) + ignore (define_term n sigma (List.hd abstracted) false) with _ -> (* Temporary, hack to support arguments *) let num_args = List.length (config.args_base) in let num_discard = nb_rel config.env - num_args in let rels = List.map (fun i -> i + num_discard) (from_one_to num_args) in let args = Array.map (fun i -> mkRel i) (Array.of_list rels) in let app = mkApp (List.hd abstracted, args) in - let _, reduced = reduce_term config.env evm app in + let sigma, reduced = reduce_term config.env sigma app in let reconstructed = reconstruct_lambda config.env reduced in - ignore (define_term n evm reconstructed false) + ignore (define_term n sigma reconstructed false) else failwith "Failed to abstract" (* Factor a term into a sequence of lemmas *) let factor n trm : unit = - let (evm, env) = Pfedit.get_current_context() in - let evm, def = intern env evm trm in + let (sigma, env) = Pfedit.get_current_context () in + let sigma, def = intern env sigma trm in let body = lookup_definition env def in - let fs = reconstruct_factors (snd (factor_term env body evm)) in + let sigma, fs = + bind + (factor_term env body) + (fun fs -> ret (reconstruct_factors fs)) + sigma + in let prefix = Id.to_string n in try List.iteri (fun i lemma -> let lemma_id_string = String.concat "_" [prefix; string_of_int i] in let lemma_id = Id.of_string lemma_id_string in - ignore (define_term lemma_id evm lemma false); + ignore (define_term lemma_id sigma lemma false); Printf.printf "Defined %s\n" lemma_id_string) fs with _ -> failwith "Could not find lemmas" From 174bd0a51b4489ee2dd8f9f8357a1e08c28d17d1 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Thu, 5 Sep 2019 23:27:02 -0700 Subject: [PATCH 147/154] Remove unsafe typing functions :) --- plugin/src/compilation/evaluation.ml | 17 +------------ plugin/src/compilation/expansion.ml | 25 ++----------------- .../components/abstraction/abstraction.ml | 16 +----------- .../differencing/proofdifferencers.ml | 16 +----------- .../core/components/inversion/inverting.ml | 16 +----------- 5 files changed, 6 insertions(+), 84 deletions(-) diff --git a/plugin/src/compilation/evaluation.ml b/plugin/src/compilation/evaluation.ml index 89c90e0..2b4a456 100644 --- a/plugin/src/compilation/evaluation.ml +++ b/plugin/src/compilation/evaluation.ml @@ -12,22 +12,7 @@ open Declarations open Indutils open Contextutils open Stateutils - -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - * - * TODO remove this last. Will likely need good evar discipline everywhere - * else first. But can try. - *) -let infer_type (env : env) (evd : evar_map) (trm : types) = - let jmt = Typeops.infer env trm in - evd, j_type jmt - -(* --- End TODO --- *) +open Inference (* * Note: Evar discipline is not good yet, but should wait until after diff --git a/plugin/src/compilation/expansion.ml b/plugin/src/compilation/expansion.ml index b7a2905..a9e72e6 100644 --- a/plugin/src/compilation/expansion.ml +++ b/plugin/src/compilation/expansion.ml @@ -15,29 +15,8 @@ open Indutils open Contextutils open Convertibility open Envutils - -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - * - * TODO remove this last, once good evar practice in all callers - *) -let infer_type (env : env) (evd : evar_map) (trm : types) : types state = - let jmt = Typeops.infer env trm in - evd, j_type jmt - -(* Check whether a term has a given type *) -let has_type (env : env) (evd : evar_map) (typ : types) (trm : types) : bool state = - try - let evd, trm_typ = infer_type env evd trm in - convertible env evd trm_typ typ - with _ -> - evd, false - -(* --- End TODO --- *) +open Inference +open Checking (* --- Type definitions --- *) diff --git a/plugin/src/core/components/abstraction/abstraction.ml b/plugin/src/core/components/abstraction/abstraction.ml index e2d8968..278e358 100644 --- a/plugin/src/core/components/abstraction/abstraction.ml +++ b/plugin/src/core/components/abstraction/abstraction.ml @@ -22,21 +22,7 @@ open Apputils open Convertibility open Stateutils open Envutils - -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - * - * TODO remove once evar_map refactor is done (needs to be last) - *) -let infer_type (env : env) (evd : evar_map) (trm : types) = - let jmt = Typeops.infer env trm in - evd, j_type jmt - -(* --- End TODO --- *) +open Inference (* Internal options for abstraction *) type abstraction_options = diff --git a/plugin/src/core/components/differencing/proofdifferencers.ml b/plugin/src/core/components/differencing/proofdifferencers.ml index 9042873..42fd6b5 100644 --- a/plugin/src/core/components/differencing/proofdifferencers.ml +++ b/plugin/src/core/components/differencing/proofdifferencers.ml @@ -19,21 +19,7 @@ open Idutils open Stateutils open Convertibility open Envutils - -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - * - * TODO fix this last - *) -let infer_type (env : env) (evd : evar_map) (trm : types) = - let jmt = Typeops.infer env trm in - evd, j_type jmt - -(* --- End TODO --- *) +open Inference (* --- Utilities --- *) diff --git a/plugin/src/core/components/inversion/inverting.ml b/plugin/src/core/components/inversion/inverting.ml index 9ad2a88..7c1106a 100644 --- a/plugin/src/core/components/inversion/inverting.ml +++ b/plugin/src/core/components/inversion/inverting.ml @@ -17,24 +17,10 @@ open Equtils open Convertibility open Stateutils open Envutils +open Inference type inverter = (env * types) -> evar_map -> ((env * types) option) state -(* --- TODO for refactoring without breaking things --- *) - -(* - * Infer the type of trm in env - * Note: This does not yet use good evar map hygeine; will fix that - * during the refactor. - * - * TODO port this one last - *) -let infer_type (env : env) (sigma : evar_map) (trm : types) = - let jmt = Typeops.infer env trm in - sigma, j_type jmt - -(* --- End TODO --- *) - (* --- Inverting type paths --- *) (* From 6f561be57ee9d1d1c6ed0429b268fd46c0091e4d Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 19:10:03 -0700 Subject: [PATCH 148/154] License --- LICENSE | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 LICENSE diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..6ca658e --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2017-2019 Talia Ringer, Nate Yazdani + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. From a0e195c0d0079cce54d710e799cfee148d749db0 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 19:12:31 -0700 Subject: [PATCH 149/154] Update dependency on DEVOID to use master --- .gitmodules | 1 - licensing/LICENSE | 21 --------------------- 2 files changed, 22 deletions(-) delete mode 100644 licensing/LICENSE diff --git a/.gitmodules b/.gitmodules index 1c19b69..6e295c4 100644 --- a/.gitmodules +++ b/.gitmodules @@ -7,4 +7,3 @@ [submodule "plugin/deps/ornamental-search"] path = plugin/deps/ornamental-search url = https://github.com/uwplse/ornamental-search.git - branch = 0.1 diff --git a/licensing/LICENSE b/licensing/LICENSE deleted file mode 100644 index 268b9ba..0000000 --- a/licensing/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -The MIT License (MIT) - -Copyright (c) 2017 Talia Ringer, Nate Yazdani - -Permission is hereby granted, free of charge, to any person obtaining a copy -of this software and associated documentation files (the "Software"), to deal -in the Software without restriction, including without limitation the rights -to use, copy, modify, merge, publish, distribute, sublicense, and/or sell -copies of the Software, and to permit persons to whom the Software is -furnished to do so, subject to the following conditions: - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. From 0d7c37df9d6d024527d11c7c002269fab4d64ac2 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 19:14:27 -0700 Subject: [PATCH 150/154] Update all libraries --- plugin/deps/fix-to-elim | 2 +- plugin/deps/ornamental-search | 2 +- plugin/src/coq-plugin-lib | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/plugin/deps/fix-to-elim b/plugin/deps/fix-to-elim index f2e37b1..6c7f408 160000 --- a/plugin/deps/fix-to-elim +++ b/plugin/deps/fix-to-elim @@ -1 +1 @@ -Subproject commit f2e37b1c13321937d5410ba7cd75ed0d9cc22cc2 +Subproject commit 6c7f4084a661ebbd6c3703a53c9f34b44a404e15 diff --git a/plugin/deps/ornamental-search b/plugin/deps/ornamental-search index 3b757ee..c1189ef 160000 --- a/plugin/deps/ornamental-search +++ b/plugin/deps/ornamental-search @@ -1 +1 @@ -Subproject commit 3b757eea2d94c8d2f13823a4108caeba871f01c1 +Subproject commit c1189ef5a099f6c9df785accaba3472e425bd316 diff --git a/plugin/src/coq-plugin-lib b/plugin/src/coq-plugin-lib index 2249871..e22bf02 160000 --- a/plugin/src/coq-plugin-lib +++ b/plugin/src/coq-plugin-lib @@ -1 +1 @@ -Subproject commit 2249871ed38e53e3a83763238a5c85a146e87b66 +Subproject commit e22bf02465ad0b00fbeafbb11bb0579d92eaa425 From bbc58eafc9f77cee503005d1d63c7538365bfbbd Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 21:25:50 -0700 Subject: [PATCH 151/154] Update rEADME --- README.md | 67 ++++++++++++++++++++++++++++++++++++++++++------------- 1 file changed, 52 insertions(+), 15 deletions(-) diff --git a/README.md b/README.md index 9d570af..58324fb 100644 --- a/README.md +++ b/README.md @@ -1,19 +1,29 @@ -**!!! IMPORTANT NOTE: If you came here for DEVOID, it is currently located [here](https://github.com/uwplse/ornamental-search). By ITP, this plugin will include DEVOID as a dependency. !!!** +Welcome to the PUMPKIN PATCH proof repair plugin suite! +This plugin suite is a collection of plugins for maintaining proofs as +specifications change over time: -# PUMPKIN PATCH User Guide +* PUMPKIN PATCH ([paper](http://tlringer.github.io/pdf/pumpkinpaper.pdf), [talk video](http://www.youtube.com/watch?v=p-V9oerg5DU)): example-based proof repair +* DEVOID ([paper](http://tlringer.github.io/pdf/ornpaper.pdf), [standalone plugin](https://github.com/uwplse/ornamental-search)): reusing functions and proofs over unindexed types to derive indexed versions + +In addition, this plugin suite includes some development tools, like +the [fix-to-elim](https://github.com/uwplse/fix-to-elim) plugin for automatic +fixpoint translation, that may be useful for plugin developers and Coq +contributors more broadly. We discuss these briefly at the end of the document. + +All of these tools, including DEVOID, are included as dependencies of the +main PUMPKIN PATCH plugin, so you can use both at the same time. +**More information on using DEVOID +can be found in the the standalone plugin repository. The remainder of this +document will focus on how to use the main PUMPKIN PATCH plugin.** +We hope to add an example of using these both together soon. + +# PUMPKIN PATCH for Users This is a prototype plugin for finding patches for broken Coq proofs. To use PUMPKIN, the programmer modifies a single proof script to provide an _example_ adaptation of a proof to a change. PUMPKIN generalizes this example into a _reusable patch_ which can be used to fix other broken proofs. -This is a research prototype, so it is definitely not production-ready. -With that in mind, I hope that by getting it out into the open I can -contribute what I've learned so far. You can use it on the example proofs and -you can extend it if you are interested. Don't hesitate to reach out -if you have any questions. Similarly, please let me know if anything I have mentioned -in this user guide does not work or is unclear. - Reading the [paper](http://tlringer.github.io/pdf/pumpkinpaper.pdf) may help if you are interested in understanding the internals of the tool. The paper links to a release that captures the code as it was when we wrote the paper. The [talk video](http://www.youtube.com/watch?v=p-V9oerg5DU) @@ -175,6 +185,7 @@ Patch Proof Old'.old New'.new as patch. See [Preprocess.v](/plugin/coq/Preprocess.v) and [PreprocessModule.v](/plugin/coq/PreprocessModule.v) for examples of how to use these commands. There are also proofs in [Regress.v](/plugin/coq/Regress.v) and [IntegersNew.v](/plugin/coq/IntegersNew.v) that demonstrate its use with `Patch Proof`. +This command is available as a [standalone plugin](https://github.com/uwplse/fix-to-elim) as well, if you are interested. ### Cutting Lemmas @@ -211,7 +222,7 @@ around limitations. ### Support & Limitations -Speaking of limitations: PUMPKIN is a research prototype, and so it is currently limited in the +PUMPKIN is a research prototype, and so it is currently limited in the kinds of proofs and changes it supports. PUMPKIN is best equipped to handle changes in conclusions of inductive proofs. It has introductory support for changes in hypotheses. It also supports certain changes in definitions (for example, changes in a constructors @@ -219,8 +230,12 @@ of an inductive type that a proof inducts over, or changes in a case of a fixpoi and some other styles of proofs (for example, simple applicative proofs, or proofs that apply constructors). -PUMPKIN does not yet support structural changes like adding new hypotheses, -adding constructors or parameters to an inductive type, or adding cases to a fixpoint. +With the help of [DEVOID](https://github.com/uwplse/ornamental-search), PUMPKIN +can also handle certain changes from unindexed types to indexed versions. +Please see the DEVOID repository for more of those examples. + +PUMPKIN does not yet support adding new hypotheses, +adding constructors to an inductive type, or adding cases to a fixpoint. PUMPKIN has very limited support for proofs using logic specific to decidable domains (such as proofs that use `omega`) and nested induction. Supporting all of these features is on our roadmap. @@ -284,10 +299,20 @@ The relevant examples are as follows: 9. [Theorem.v](/plugin/coq/Theorem.v): Example fo the experimental theorem patching command 10. [Hypotheses.v](/plugin/coq/Hypotheses.v): Very simple changes in hypotheses. -## Extending PUMPKIN +# PUMPKIN PATCH for Developers + +We welcome contributors! Especially those willing to help us +with build tools, continuous integration, updating Coq versions, +documentation, and other infrastructure. + +In addition, we have included some useful infrastructure for plugin +developers more broadly. + +## Contributing If you've never written a Coq plugin before, you might want to check out -and toy with my [starter plugin](http://github.com/uwplse/CoqAST/) first. +the [plugin tutorials](https://github.com/coq/coq/tree/master/doc/plugin_tutorial) +in the main Coq repository. To get an idea of how the code is structured, I highly recommend reading Section 5 of the paper and following along in the code. The entry-point to the code is [patcher.ml4](/plugin/src/patcher.ml4). @@ -298,7 +323,14 @@ if you are modifying the tool, you may want to use it. Minor note: .ml4 files don't appear to work with a lot of emacs OCaml plugins. You can run tuareg-mode manually on .ml4 files. -## Contributors +## Developer Tools + +This plugin suite includes two useful tools for plugin developers: + +* The [fix-to-elim](https://github.com/uwplse/fix-to-elim) plugin for translating fixpoints to inductive proofs +* The [coq-plugin-lib](https://github.com/uwplse/coq-plugin-lib) library for plugin development + +# Contributors This plugin is maintained by Talia Ringer with help from Nate Yazdani. John Leo and Dan Grossman have made conceptual contributions. @@ -306,3 +338,8 @@ John Leo and Dan Grossman have made conceptual contributions. The following community members have also contributed to the code: 1. Emilio Jesús Gallego Arias 2. Your name here! + +# Licensing + +We use the MIT license because we think that Coq plugins are allowed to do so. +If this is incorrect, please let us know kindly so we can fix it. From c2ad1fd595578e7988abf7b6a9a4bcd494644fba Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 21:27:37 -0700 Subject: [PATCH 152/154] accidentall chagne --- plugin/coq/Induction.v | 7 ------- 1 file changed, 7 deletions(-) diff --git a/plugin/coq/Induction.v b/plugin/coq/Induction.v index 6984f80..c6e9a3e 100644 --- a/plugin/coq/Induction.v +++ b/plugin/coq/Induction.v @@ -321,13 +321,6 @@ Definition cut := S (a + S a) = S (S (a + a)) -> S (a + S (a + 0)) = S (S (a + (a + 0))). -Definition test_1 (b0 : bin) := - (S ((bin_to_nat b0) + (S ((bin_to_nat b0) + O)))) = (S (S ((bin_to_nat b0) + ((bin_to_nat b0) + O)))). - -Definition test_2 (b0 : bin) := - ((S ((bin_to_nat b0) + (S (bin_to_nat b0)))) = (S (S ((bin_to_nat b0) + (bin_to_nat b0))))). - - (* Patch *) Patch Proof blindfs_induction.bin_to_nat_pres_incr bin_to_nat_pres_incr cut by (fun (H : cut) b0 => H (bin_to_nat b0)) as patch. Print patch. From cbce2b08596fe1ab1cce5e834ce72c8fbb7e124d Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 21:30:01 -0700 Subject: [PATCH 153/154] note on bug --- plugin/coq/Optimization.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plugin/coq/Optimization.v b/plugin/coq/Optimization.v index ac63ae6..3a7e512 100644 --- a/plugin/coq/Optimization.v +++ b/plugin/coq/Optimization.v @@ -227,7 +227,7 @@ Definition add_0_r_5_expected (n : nat) : n + 0 = n := * PUMPKIN manages to find the most efficient proof, probably because * there are no inductive hypotheses of the form A -> B. * - * TODO: Broken. Fix before merging back into master. Not sure what changed. + * NOTE: Broken. Fix soon. Not crucial to release. *) Fail Theorem test_opt_7 : add_0_r_5 = add_0_r_5_expected. @@ -258,7 +258,7 @@ Optimize Proof Term add_0_r_slow_6' as add_0_r_6. (* * This gives us the same result: * - * TODO broken. Fix before merging back into master. + * NOTE: Broken. Fix soon. Not crucial to release. *) Fail Theorem test_opt_8 : add_0_r_6 = add_0_r_5_expected. From c751dea4603ef502726a81b43f757c9bff419da4 Mon Sep 17 00:00:00 2001 From: Talia Ringer Date: Fri, 6 Sep 2019 21:32:02 -0700 Subject: [PATCH 154/154] eh --- plugin/src/core/components/differencing/appdifferencers.ml | 3 --- 1 file changed, 3 deletions(-) diff --git a/plugin/src/core/components/differencing/appdifferencers.ml b/plugin/src/core/components/differencing/appdifferencers.ml index 7760413..0cc8f66 100644 --- a/plugin/src/core/components/differencing/appdifferencers.ml +++ b/plugin/src/core/components/differencing/appdifferencers.ml @@ -137,9 +137,6 @@ let diff_app diff_f diff_arg opts d = * then specialize to any final arguments. * * For changes in constructors, hypotheses, or fixpoint cases, don't specialize. - * - * TODO: Revisit when to use sigma_f once we have the recursers threading - * evar_maps correctly, before merging to master. Clean when you do that. *) let diff_app_ind diff_ind diff_arg opts d = let d_proofs = erase_goals d in