aac-tactics-8.18.0/0000755000175000017500000000000014463022056013406 5ustar jpuydtjpuydtaac-tactics-8.18.0/dune-project0000644000175000017500000000006314463022056015727 0ustar jpuydtjpuydt(lang dune 2.8) (using coq 0.3) (name aac-tactics) aac-tactics-8.18.0/LICENSE0000644000175000017500000002002514463022056014412 0ustar jpuydtjpuydtCopyright (C) 2009-2018 Thomas Braibant, Damien Pous, Fabian Kunze The AAC tactics plugin library is free software: you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more details. GNU LESSER GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below. 0. Additional Definitions. As used herein, "this License" refers to version 3 of the GNU Lesser General Public License, and the "GNU GPL" refers to version 3 of the GNU General Public License. "The Library" refers to a covered work governed by this License, other than an Application or a Combined Work as defined below. An "Application" is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library. A "Combined Work" is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the "Linked Version". The "Minimal Corresponding Source" for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version. The "Corresponding Application Code" for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work. 1. Exception to Section 3 of the GNU GPL. You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL. 2. Conveying Modified Versions. If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version: a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy. 3. Object Code Incorporating Material from Library Header Files. The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following: a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the object code with a copy of the GNU GPL and this license document. 4. Combined Works. You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following: a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the Combined Work with a copy of the GNU GPL and this license document. c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document. d) Do one of the following: 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source. 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version. e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.) 5. Combined Libraries. You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License. b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 6. Revised Versions of the GNU Lesser General Public License. The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation. If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library. aac-tactics-8.18.0/coq-aac-tactics.opam0000644000175000017500000000314314463022056017221 0ustar jpuydtjpuydt# This file was generated from `meta.yml`, please do not edit manually. # Follow the instructions on https://github.com/coq-community/templates to regenerate. opam-version: "2.0" maintainer: "palmskog@gmail.com" version: "8.18.dev" homepage: "https://github.com/coq-community/aac-tactics" dev-repo: "git+https://github.com/coq-community/aac-tactics.git" bug-reports: "https://github.com/coq-community/aac-tactics/issues" license: "LGPL-3.0-or-later" synopsis: "Coq tactics for rewriting universally quantified equations, modulo associative (and possibly commutative and idempotent) operators" description: """ This Coq plugin provides tactics for rewriting and proving universally quantified equations modulo associativity and commutativity of some operator, with idempotent commutative operators enabling additional simplifications. The tactics can be applied for custom operators by registering the operators and their properties as type class instances. Instances for many commonly used operators, such as for binary integer arithmetic and booleans, are provided with the plugin.""" build: ["dune" "build" "-p" name "-j" jobs] depends: [ "ocaml" {>= "4.09.0"} "dune" {>= "2.8"} "coq" {>= "8.18" & < "8.19"} ] tags: [ "category:Miscellaneous/Coq Extensions" "category:Computer Science/Decision Procedures and Certified Algorithms/Decision procedures" "keyword:reflexive tactic" "keyword:rewriting" "keyword:rewriting modulo associativity and commutativity" "keyword:rewriting modulo ac" "keyword:decision procedure" "logpath:AAC_tactics" ] authors: [ "Thomas Braibant" "Damien Pous" "Fabian Kunze" ] aac-tactics-8.18.0/.gitignore0000644000175000017500000000033014463022056015372 0ustar jpuydtjpuydt*.aux *.a *.cma *.cmi *.cmo *.cmx *.cmxa *.cmxs *.cmt *.cmti *.glob *.native *.o *.d *.vio *.vo *.vos *.vok .coq-native src/aac.ml .lia.cache .merlin Makefile.coq Makefile.coq.conf META.coq-aac-tactics _build docs/ aac-tactics-8.18.0/src/0000755000175000017500000000000014463022056014175 5ustar jpuydtjpuydtaac-tactics-8.18.0/src/theory.mli0000644000175000017500000001711614463022056016220 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Bindings for Coq constants that are specific to the plugin; reification and translation functions. Note: this module is highly correlated with the definitions of {i AAC_rewrite.v}. This module interfaces with the above Coq module; it provides facilities to interpret a term with arbitrary operators as an abstract syntax tree, and to convert an AST into a Coq term (either using the Coq "raw" terms, as written in the starting goal, or using the reified Coq datatypes we define in {i AAC_rewrite.v}). *) open Coq (** Both in OCaml and Coq, we represent finite multisets using weighted lists ([('a*int) list]), see {!Matcher.mset}. [mk_mset ty l] constructs a Coq multiset from an OCaml multiset [l] of Coq terms of type [ty] *) val mk_mset:EConstr.constr -> (EConstr.constr * int) list ->EConstr.constr (** {2 Packaging modules} *) (** Environments *) module Sigma: sig (** [add ty n x map] adds the value [x] of type [ty] with key [n] in [map] *) val add: EConstr.constr ->EConstr.constr ->EConstr.constr ->EConstr.constr ->EConstr.constr (** [empty ty] create an empty map of type [ty] *) val empty: EConstr.constr ->EConstr.constr (** [of_list ty null l] translates an OCaml association list into a Coq one *) val of_list: EConstr.constr -> EConstr.constr -> (int * EConstr.constr ) list -> EConstr.constr (** [to_fun ty null map] converts a Coq association list into a Coq function (with default value [null]) *) val to_fun: EConstr.constr ->EConstr.constr ->EConstr.constr ->EConstr.constr end (** Dynamically typed morphisms *) module Sym: sig (** mimics the Coq record [Sym.pack] *) type pack = {ar: Constr.t; value: Constr.t ; morph: Constr.t} val typ: lazy_ref (** [mk_pack rlt (ar,value,morph)] *) val mk_pack: Coq.Relation.t -> pack -> EConstr.constr (** [null] builds a dummy (identity) symbol, given an {!Coq.Relation.t} *) val null: Coq.Relation.t -> EConstr.constr end (** We need to export some Coq stubs out of this module. They are used by the main tactic, see {!Rewrite} *) module Stubs : sig val lift : lazy_ref val lift_proj_equivalence : lazy_ref val lift_transitivity_left : lazy_ref val lift_transitivity_right : lazy_ref val lift_reflexivity : lazy_ref (** The evaluation fonction, used to convert a reified coq term to a raw coq term *) val eval: lazy_ref (** The main lemma of our theory, that is [compare (norm u) (norm v) = Eq -> eval u == eval v] *) val decide_thm: lazy_ref val lift_normalise_thm : lazy_ref end (** {2 Building reified terms} We define a bundle of functions to build reified versions of the terms (those that will be given to the reflexive decision procedure). In particular, each field takes as first argument the index of the symbol rather than the symbol itself. *) (** Tranlations between Coq and OCaml *) module Trans : sig (** This module provides facilities to interpret a term with arbitrary operators as an instance of an abstract syntax tree {!Matcher.Terms.t}. For each Coq application [f x_1 ... x_n], this amounts to deciding whether one of the partial applications [f x_1 ... x_i], [i<=n] is a proper morphism, whether the partial application with [i=n-2] yields an A or AC binary operator, and whether the whole term is the unit for some A or AC operator. We use typeclass resolution to test each of these possibilities. Note that there are ambiguous terms: - a term like [f x y] might yield a unary morphism ([f x]) and a binary one ([f]); we select the latter one (unless [f] is A or AC, in which case we declare it accordingly); - a term like [S O] can be considered as a morphism ([S]) applied to a unit for [(+)], or as a unit for [( * )]; we chose to give priority to units, so that the latter interpretation is selected in this case; - an element might be the unit for several operations *) (** To achieve this reification, one need to record informations about the collected operators (symbols, binary operators, units). We use the following imperative internal data-structure to this end. *) type envs val empty_envs : unit -> envs (** {2 Reification: from Coq terms to AST {!Matcher.Terms.t} } *) (** [t_of_constr goal rlt envs (left,right)] builds the abstract syntax tree of the terms [left] and [right]. We rely on the [goal] to perform typeclasses resolutions to find morphisms compatible with the relation [rlt]. Doing so, it modifies the reification environment [envs]. Moreover, we need to create fresh evars; this is why we give back the [goal], accordingly updated. *) val t_of_constr : Environ.env -> Evd.evar_map -> Coq.Relation.t -> envs -> (EConstr.constr * EConstr.constr) -> Matcher.Terms.t * Matcher.Terms.t * Evd.evar_map (** [add_symbol] adds a given binary symbol to the environment of known stuff. *) val add_symbol : Environ.env -> Evd.evar_map -> Coq.Relation.t -> envs -> Constr.t -> Evd.evar_map (** {2 Reconstruction: from AST back to Coq terms } The next functions allow one to map OCaml abstract syntax trees to Coq terms. We need two functions to rebuild different kind of terms: first, raw terms, like the one encountered by {!t_of_constr}; second, reified Coq terms, that are required for the reflexive decision procedure. *) type ir val ir_of_envs : Environ.env -> Evd.evar_map -> Coq.Relation.t -> envs -> Evd.evar_map * ir val ir_to_units : ir -> Matcher.ext_units (** {2 Building raw, natural, terms} *) (** [raw_constr_of_t] rebuilds a term in the raw representation, and reconstruct the named products on top of it. In particular, this allow us to print the context put around the left (or right) hand side of a pattern. *) val raw_constr_of_t : ir -> Coq.Relation.t -> EConstr.rel_context -> Matcher.Terms.t -> EConstr.constr (** {2 Building reified terms} *) (** The reification environments, as Coq constrs *) type sigmas = { env_sym : EConstr.constr; env_bin : EConstr.constr; env_units : EConstr.constr; (* the [idx -> X:constr] *) } (** We need to reify two terms (left and right members of a goal) that share the same reification envirnoment. Therefore, we need to add letins to the proof context in order to ensure some sharing in the proof terms we produce. Moreover, in order to have as much sharing as possible, we also add letins for various partial applications that are used throughout the terms. To achieve this, we decompose the reconstruction function into two steps: first, we build the reification environment and then reify each term successively.*) type reifier val mk_reifier : Coq.Relation.t -> EConstr.constr -> ir -> (sigmas * reifier) Proofview.tactic (** [reif_constr_of_t reifier t] rebuilds the term [t] in the reified form. *) val reif_constr_of_t : reifier -> Matcher.Terms.t -> EConstr.constr end aac-tactics-8.18.0/src/helper.ml0000644000175000017500000000223514463022056016010 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) module type CONTROL = sig val debug : bool val time : bool val printing : bool end module Debug (X : CONTROL) = struct open X let debug x = if debug then Printf.printf "%s\n%!" x let time f x fmt = if time then let t = Sys.time () in let r = f x in Printf.printf fmt (Sys.time () -. t); r else f x let pr_constr env evd msg constr = if printing then ( Feedback.msg_notice (Pp.str (Printf.sprintf "=====%s====" msg)); Feedback.msg_notice (Printer.pr_econstr_env env evd constr); ) let debug_exception msg e = debug (msg ^ (Printexc.to_string e)) end aac-tactics-8.18.0/src/search_monad.mli0000644000175000017500000000265414463022056017332 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Search monad that allows to express non-deterministic algorithms in a legible maner, or programs that solve combinatorial problems. @see the inspiration of this module *) (** A data type that represent a collection of ['a] *) type 'a m (** {2 Monadic operations} *) (** bind and return *) val ( >> ) : 'a m -> ('a -> 'b m) -> 'b m val return : 'a -> 'a m (** non-deterministic choice *) val ( >>| ) : 'a m -> 'a m -> 'a m (** failure *) val fail : unit -> 'a m (** folding through the collection *) val fold : ('a -> 'b -> 'b) -> 'a m -> 'b -> 'b (** {2 Derived facilities } *) val sprint : ('a -> string) -> 'a m -> string val count : 'a m -> int val choose : 'a m -> 'a option val to_list : 'a m -> 'a list val sort : ('a -> 'a -> int) -> 'a m -> 'a m val is_empty: 'a m -> bool val filter : ('a -> bool) -> 'a m -> 'a m aac-tactics-8.18.0/src/aac_rewrite.mli0000644000175000017500000000173414463022056017172 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** aac_rewrite -- rewriting modulo A or AC*) val aac_reflexivity : unit Proofview.tactic val aac_normalise : unit Proofview.tactic val aac_rewrite : args:(string * int) list -> ?abort:bool -> ?l2r:bool -> ?show:bool -> ?strict:bool -> ?extra:EConstr.t -> EConstr.constr -> unit Proofview.tactic val add : string -> 'a -> (string * 'a) list -> (string * 'a) list val pr_aac_args : 'a -> 'b -> 'c -> (string * int) list -> Pp.t aac-tactics-8.18.0/src/coq.ml0000644000175000017500000003770414463022056015324 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Interface with Coq *) open Constr open EConstr open Names open Context.Rel.Declaration open Proofview.Notations type tactic = unit Proofview.tactic let mkArrow x y = mkArrow x Sorts.Relevant y (* The kernel will fix the relevance if needed. Also as an equality tactic we probably are only called on relevant terms. *) type lazy_ref = Names.GlobRef.t Lazy.t (* The contrib name is used to locate errors when loading constrs *) let contrib_name = "aac_tactics" let aac_lib_ref s = Coqlib.lib_ref (contrib_name ^ "." ^ s) let find_global s = lazy (aac_lib_ref s) let new_monomorphic_global gr = try UnivGen.constr_of_monomorphic_global (Global.env ()) gr with _e -> CErrors.anomaly Pp.(str "new_monomorphic_global raised an error on:" ++ Printer.pr_global gr) (* Getting constrs (primitive Coq terms) from existing Coq libraries. *) let get_fresh r = new_monomorphic_global (Lazy.force r) let get_efresh r = EConstr.of_constr (new_monomorphic_global (Lazy.force r)) (* A clause specifying that the [let] should not try to fold anything in the goal *) let nowhere = { Locus.onhyps = Some []; Locus.concl_occs = Locus.NoOccurrences } let retype c = Proofview.Goal.enter begin fun gl -> let sigma, _ = Typing.type_of (Proofview.Goal.env gl) (Proofview.Goal.sigma gl) c in Proofview.Unsafe.tclEVARS sigma end (* similar to retype above. No Idea when/why this is needed, I smell some ugly hack. Apparently, it has to do with the need to recompute universe constrains if we just compose terms *) let tclRETYPE c= let open Proofview in tclEVARMAP >>= fun sigma -> Proofview.Goal.enter (fun goal -> let env = Proofview.Goal.env goal in let sigma,_ = Typing.type_of env sigma c in Unsafe.tclEVARS sigma ) (** {1 Tacticals} *) let tclTIME msg tac = Proofview.Goal.enter begin fun gl -> let u = Sys.time () in tac >>= fun r -> let _ = Feedback.msg_notice (Pp.str (Printf.sprintf "%s:%fs" msg (Sys.time ()-. u))) in Proofview.tclUNIT r end let tclDEBUG msg = let open Proofview in tclBIND (tclUNIT ()) (fun _ -> let _ = Feedback.msg_debug (Pp.str msg) in tclUNIT ()) let tclPRINT = let open Proofview in Proofview.Goal.enter (fun goal -> let _ = Feedback.msg_notice (Printer.Debug.pr_goal goal) in tclUNIT ()) let show_proof pstate : unit = let sigma, env = Declare.Proof.get_current_context pstate in let p = Declare.Proof.get pstate in let p = Proof.partial_proof p in let p = List.map (Evarutil.nf_evar sigma) p in let () = List.iter (fun c -> Feedback.msg_notice (Printer.pr_econstr_env env sigma c)) p (* list of econstr in sigma *) in () let cps_mk_letin (name:string) (c: constr) (k : constr -> tactic) : tactic = Proofview.Goal.enter begin fun goal -> let name = (Id.of_string name) in let name = Tactics.fresh_id_in_env Id.Set.empty name (Tacmach.pf_env goal) in let letin = Tactics.letin_tac None (Name name) c None nowhere in Tacticals.tclTHENLIST [retype c; letin; (k (mkVar name))] end let mk_letin (name:string) (c: constr) : constr Proofview.tactic = let open Proofview in let name = (Id.of_string name) in Proofview.Goal.enter_one (fun goal -> let env = Proofview.Goal.env goal in let name = Tactics.fresh_id_in_env Id.Set.empty name env in tclRETYPE c (* this fixes universe constrains problems in c *) <*> Tactics.pose_tac (Name name) c <*> tclUNIT (mkVar name) ) (** {1 General functions} *) let resolve_one_typeclass env sigma ty : constr * Evd.evar_map = let sigma, c = Typeclasses.resolve_one_typeclass env sigma ty in c, sigma let cps_resolve_one_typeclass ?error : types -> (constr -> tactic) -> tactic = fun t k -> Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let em = Proofview.Goal.sigma gl in let em, c = try Typeclasses.resolve_one_typeclass env em t with Not_found -> begin match error with | None -> CErrors.anomaly (Pp.str "Cannot resolve a typeclass : please report") | Some x -> CErrors.user_err x end in Tacticals.tclTHENLIST [Proofview.Unsafe.tclEVARS em; k c] end (* TODO: refactor following similar functions*) let evar_binary env (sigma: Evd.evar_map) (x : constr) = let ty = mkArrow x (mkArrow x x) in Evarutil.new_evar env sigma ty let evar_relation env (sigma: Evd.evar_map) (x: constr) = let ty = mkArrow x (mkArrow x (mkSort (ESorts.make Sorts.prop))) in Evarutil.new_evar env sigma ty let decomp_term sigma c = kind sigma (Termops.strip_outer_cast sigma c) (** {2 Bindings with Coq' Standard Library} *) module Std = struct (* Here we package the module to be able to use List, later *) module Pair = struct let typ = find_global "pair.prod" let pair = find_global "pair.pair" let of_pair t1 t2 (x,y) = mkApp (get_efresh pair, [| t1; t2; x ; y|] ) end module Option = struct let typ = find_global "option.typ" let some = find_global "option.Some" let none = find_global "option.None" let some t x = mkApp (get_efresh some, [| t ; x|]) let none t = mkApp (get_efresh none, [| t |]) let of_option t x = match x with | Some x -> some t x | None -> none t end module Pos = struct let typ = find_global "pos.typ" let xI = find_global "pos.xI" let xO = find_global "pos.xO" let xH = find_global "pos.xH" (* A coq positive from an int *) let of_int n = let rec aux n = begin match n with | n when n < 1 -> assert false | 1 -> get_efresh xH | n -> mkApp ( (if n mod 2 = 0 then get_efresh xO else get_efresh xI ), [| aux (n/2)|] ) end in aux n end module Nat = struct let typ = find_global "nat.type" let _S = find_global "nat.S" let _O = find_global "nat.O" (* A coq nat from an int *) let rec of_int n = begin match n with | n when n < 0 -> assert false | 0 -> get_fresh _O | n -> Constr.mkApp ( ( get_fresh _S ), [| of_int (n-1)|] ) end end (** Lists from the standard library*) module List = struct let typ = find_global "list.typ" let nil = find_global "list.nil" let cons = find_global "list.cons" let cons ty h t = mkApp (get_efresh cons, [| ty; h ; t |]) let nil ty = (mkApp (get_efresh nil, [| ty |])) let rec of_list ty = function | [] -> nil ty | t::q -> cons ty t (of_list ty q) let type_of_list ty = mkApp (get_efresh typ, [|ty|]) end (** Morphisms *) module Classes = struct let morphism = find_global "coq.classes.morphisms.Proper" let equivalence = find_global "coq.RelationClasses.Equivalence" let reflexive = find_global "coq.RelationClasses.Reflexive" let transitive = find_global "coq.RelationClasses.Transitive" (** build the type [Equivalence ty rel] *) let mk_equivalence ty rel = mkApp (get_efresh equivalence, [| ty; rel|]) (** build the type [Reflexive ty rel] *) let mk_reflexive ty rel = mkApp (get_efresh reflexive, [| ty; rel|]) (** build the type [Proper rel t] *) let mk_morphism ty rel t = mkApp (get_efresh morphism, [| ty; rel; t|]) (** build the type [Transitive ty rel] *) let mk_transitive ty rel = mkApp (get_efresh transitive, [| ty; rel|]) end module Relation = struct type t = { carrier : constr; r : constr; } let make ty r = {carrier = ty; r = r } let split t = t.carrier, t.r end module Equivalence = struct type t = { carrier : constr; eq : constr; equivalence : constr; } let make ty eq equivalence = {carrier = ty; eq = eq; equivalence = equivalence} let infer env sigma ty eq = let ask = Classes.mk_equivalence ty eq in let equivalence, sigma = resolve_one_typeclass env sigma ask in make ty eq equivalence, sigma let from_relation env sigma rlt = infer env sigma (rlt.Relation.carrier) (rlt.Relation.r) let to_relation t = {Relation.carrier = t.carrier; Relation.r = t.eq} let split t = t.carrier, t.eq, t.equivalence end end (**[ match_as_equation env sigma eqt] see [eqt] as an equation. An optionnal rel-context can be provided to ensure that the term remains typable*) let match_as_equation ?(context = Context.Rel.empty) env sigma equation : (constr*constr* Std.Relation.t) option = let env = EConstr.push_rel_context context env in begin match decomp_term sigma equation with | App(c,ca) when Array.length ca >= 2 -> let n = Array.length ca in let left = ca.(n-2) in let right = ca.(n-1) in let r = (mkApp (c, Array.sub ca 0 (n - 2))) in let carrier = Retyping.get_type_of env sigma left in let rlt =Std.Relation.make carrier r in Some (left, right, rlt ) | _ -> None end (** {1 Error related mechanisms} *) (* functions to handle the failures of our tactic. Some should be reported [anomaly], some are on behalf of the user [user_error]*) let anomaly msg = CErrors.anomaly ~label:"[aac_tactics]" (Pp.str msg) let user_error msg = CErrors.user_err Pp.(str "[aac_tactics] " ++ msg) let warning msg = Feedback.msg_warning (Pp.str ("[aac_tactics]" ^ msg)) (** {1 Rewriting tactics used in aac_rewrite} *) module Rewrite = struct (** Some informations about the hypothesis, with an (informal) invariant: - [typeof hyp = hyptype] - [hyptype = forall context, body] - [body = rel left right] *) type hypinfo = { hyp : constr; (** the actual constr corresponding to the hypothese *) hyptype : constr; (** the type of the hypothesis *) context : EConstr.rel_context; (** the quantifications of the hypothese *) body : constr; (** the body of the type of the hypothesis*) rel : Std.Relation.t; (** the relation *) left : constr; (** left hand side *) right : constr; (** right hand side *) l2r : bool; (** rewriting from left to right *) } let get_hypinfo env sigma ?check_type c ~l2r : hypinfo = let ctype = Retyping.get_type_of env sigma c in let (rel_context, body_type) = decompose_prod_decls sigma ctype in let rec check f e = match decomp_term sigma e with | Rel i -> f (get_type (Context.Rel.lookup i rel_context)) | _ -> fold sigma (fun acc x -> acc && check f x) true e in begin match check_type with | None -> () | Some f -> if not (check f body_type) then user_error @@ Pp.strbrk "Unable to deal with higher-order or heterogeneous patterns"; end; begin match match_as_equation ~context:rel_context env sigma body_type with | None -> user_error @@ Pp.strbrk "The hypothesis is not an applied relation" | Some (hleft,hright,hrlt) -> { hyp = c; hyptype = ctype; body = body_type; l2r = l2r; context = rel_context; rel = hrlt ; left =hleft; right = hright; } end (* The problem : Given a term to rewrite of type [H :forall xn ... x1, t], we have to instanciate the subset of [xi] of type [carrier]. [subst : (int * constr)] is the mapping the debruijn indices in [t] to the [constrs]. We need to handle the rest of the indexes. Two ways : - either using fresh evars and rewriting [H tn ?1 tn-2 ?2 ] - either building a term like [fun 1 2 => H tn 1 tn-2 2] Both these terms have the same type. *) (* Fresh evars for everyone (should be the good way to do this recompose in Coq v8.4) *) (* let recompose_prod * (context : rel_context) * (subst : (int * constr) list) * env * em * : Evd.evar_map * constr list = * (\* the last index of rel relevant for the rewriting *\) * let min_n = List.fold_left * (fun acc (x,_) -> min acc x) * (List.length context) subst in * let rec aux context acc em n = * let _ = Printf.printf "%i\n%!" n in * match context with * | [] -> * env, em, acc * | t::q -> * let env, em, acc = aux q acc em (n+1) in * if n >= min_n * then * let em,x = * try em, List.assoc n subst * with | Not_found -> * let (em, r) = Evarutil.new_evar env em (Vars.substl acc (get_type t)) in * (em, r) * in * (EConstr.push_rel t env), em,x::acc * else * env,em,acc * in * let _,em,acc = aux context [] em 1 in * em, acc *) (* no fresh evars : instead, use a lambda abstraction around an application to handle non-instantiated variables. *) let recompose_prod' (context : rel_context) (subst : (int *constr) list) c = let rec popn pop n l = if n <= 0 then l else match l with | [] -> [] | t::q -> pop t :: (popn pop (n-1) q) in let pop_rel_decl = map_type Termops.pop in let rec aux sign n next app ctxt = match sign with | [] -> List.rev app, List.rev ctxt | decl::sign -> try let term = (List.assoc n subst) in aux sign (n+1) next (term::app) (None :: ctxt) with | Not_found -> let term = mkRel next in aux sign (n+1) (next+1) (term::app) (Some decl :: ctxt) in let app,ctxt = aux context 1 1 [] [] in (* substitutes in the context *) let rec update ctxt app = match ctxt,app with | [],_ -> [] | _,[] -> [] | None :: sign, _ :: app -> None :: update sign (List.map (Termops.pop) app) | Some decl :: sign, _ :: app -> Some (Vars.substl_decl app decl)::update sign (List.map (Termops.pop) app) in let ctxt = update ctxt app in (* updates the rel accordingly, taking some care not to go to far beyond: it is important not to lift indexes homogeneously, we have to update *) let rec update ctxt res n = match ctxt with | [] -> List.rev res | None :: sign -> (update (sign) (popn pop_rel_decl n res) 0) | Some decl :: sign -> update sign (decl :: res) (n+1) in let ctxt = update ctxt [] 0 in let c = applist (c,List.rev app) in let c = it_mkLambda_or_LetIn c ctxt in c (* Version de Matthieu let subst_rel_context k cstr ctx = let (_, ctx') = List.fold_left (fun (k, ctx') (id, b, t) -> (succ k, (id, Option.map (Term.substnl [cstr] k) b, Term.substnl [cstr] k t) :: ctx')) (k, []) ctx in List.rev ctx' let recompose_prod' context subst c = let len = List.length context in let rec aux sign n next app ctxt = match sign with | [] -> List.rev app, List.rev ctxt | decl::sign -> try let term = (List.assoc n subst) in aux (subst_rel_context 0 term sign) (pred n) (succ next) (term::List.map (Term.lift (-1)) app) ctxt with Not_found -> let term = Term.mkRel (len - next) in aux sign (pred n) (succ next) (term::app) (decl :: ctxt) in let app,ctxt = aux (List.rev context) len 0 [] [] in Term.it_mkLambda_or_LetIn (Term.applistc c(app)) (List.rev ctxt) *) let build (h : hypinfo) (subst : (int *constr) list) = recompose_prod' h.context subst h.hyp (* let build_with_evar * (h : hypinfo) * (subst : (int *constr) list) * (k :constr -> tactic) * : tactic * = fun goal -> * Tacmach.pf_apply * (fun env em -> * let evar_map, acc = recompose_prod h.context subst env em in * let c = applist (h.hyp,List.rev acc) in * Tacticals.tclTHENLIST [Refiner.tclEVARS evar_map; k c] goal * ) goal *) let rewrite ?(abort=false) hypinfo subst = let rew = build hypinfo subst in let tac = if not abort then Equality.general_rewrite ~where:None ~l2r:hypinfo.l2r Locus.AllOccurrences ~freeze:true (* tell if existing evars must be frozen for instantiation *) ~dep:false ~with_evars:true (rew,Tactypes.NoBindings) else Tacticals.tclIDTAC in tac end include Std aac-tactics-8.18.0/src/aac_plugin.mlpack0000644000175000017500000000007514463022056017472 0ustar jpuydtjpuydtCoq Helper Search_monad Matcher Theory Print Aac_rewrite Aac aac-tactics-8.18.0/src/print.ml0000644000175000017500000000723514463022056015672 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (* A very basic way to interact with the envs, to choose a possible solution *) open Pp open Matcher open Context.Rel.Declaration open Names type named_env = (Name.t * Terms.t) list (** {pp_env} prints a substitution mapping names to terms, using the provided printer *) let pp_env pt : named_env -> Pp.t = fun env -> List.fold_left (fun acc (v,t) -> begin match v with | Names.Name s -> str (Printf.sprintf "%s: " (Id.to_string s)) | Names.Anonymous -> str ("_") end ++ pt t ++ str "; " ++ acc ) (str "") env (** {pp_envm} prints a collection of possible environments, and number them. This number must remain compatible with the parameters given to {!aac_rewrite} *) let pp_envm pt : named_env Search_monad.m -> Pp.t = fun m -> let _,s = Search_monad.fold (fun env (n,acc) -> n+1, h (str (Printf.sprintf "%i:\t[" n) ++pp_env pt env ++ str "]") ++ fnl () :: acc ) m (0,[]) in List.fold_left (fun acc s -> s ++ acc) (str "") (s) let trivial_substitution envm = match Search_monad.choose envm with | None -> true (* assert false *) | Some l -> l=[] (** {pp_all} prints a collection of possible contexts and related possibles substitutions, giving a number to each. This number must remain compatible with the parameters of {!aac_rewrite} *) let pp_all pt : (int * Terms.t * named_env Search_monad.m) Search_monad.m -> Pp.t = fun m -> let _,s = Search_monad.fold (fun (size,context,envm) (n,acc) -> let s = str (Printf.sprintf "occurrence %i: transitivity through " n) in let s = s ++ pt context ++ str "\n" in let s = if trivial_substitution envm then s else s ++ str (Printf.sprintf "%i possible(s) substitution(s)" (Search_monad.count envm) ) ++ fnl () ++ pp_envm pt envm in n+1, s::acc ) m (0,[]) in List.fold_left (fun acc s -> s ++ str "\n" ++ acc) (str "") (s) (** The main printing function. {!print} uses the debruijn_env the rename the variables, and rebuilds raw Coq terms (for the context, and the terms in the environment). In order to do so, it requires the information gathered by the {!Theory.Trans} module.*) let print rlt ir m (context : EConstr.rel_context) : unit Proofview.tactic = if Search_monad.count m = 0 then ( Tacticals.tclFAIL (Pp.str "No subterm modulo AC") ) else let _ = Feedback.msg_notice (Pp.str "All solutions:") in let m = Search_monad.(>>) m (fun (i,t,envm) -> let envm = Search_monad.(>>) envm ( fun env -> let l = Matcher.Subst.to_list env in let l = List.sort (fun (n,_) (n',_) -> Stdlib.compare n n') l in let l = List.map (fun (v,t) -> get_name (Context.Rel.lookup v context), t ) l in Search_monad.return l ) in Search_monad.return (i,t,envm) ) in let m = Search_monad.sort (fun (x,_,_) (y,_,_) -> x - y) m in let open Proofview.Notations in Proofview.tclENV >>= fun env -> Proofview.tclEVARMAP >>= fun sigma -> let _ = Feedback.msg_notice (pp_all (fun t -> Printer.pr_letype_env env sigma (Theory.Trans.raw_constr_of_t ir rlt context t)) m ) in Tacticals.tclIDTAC aac-tactics-8.18.0/src/dune0000644000175000017500000000023514463022056015053 0ustar jpuydtjpuydt(library (name aac_plugin) (public_name coq-aac-tactics.plugin) (flags :standard -w -3-27-32) (libraries coq-core.plugins.ltac)) (coq.pp (modules aac)) aac-tactics-8.18.0/src/search_monad.ml0000644000175000017500000000376414463022056017164 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) type 'a m = | F of 'a | N of 'a m list let fold (f : 'a -> 'b -> 'b) (m : 'a m) (acc : 'b) = let rec aux acc = function F x -> f x acc | N l -> (List.fold_left (fun acc x -> match x with | (N []) -> acc | x -> aux acc x ) acc l) in aux acc m let rec (>>) : 'a m -> ('a -> 'b m) -> 'b m = fun m f -> match m with | F x -> f x | N l -> N (List.fold_left (fun acc x -> match x with | (N []) -> acc | x -> (x >> f)::acc ) [] l) let (>>|) (m : 'a m) (n :'a m) : 'a m = match (m,n) with | N [],_ -> n | _,N [] -> m | F x, N l -> N (F x::l) | N l, F x -> N (F x::l) | x,y -> N [x;y] let return : 'a -> 'a m = fun x -> F x let fail : unit -> 'a m = fun () -> N [] let sprint f m = fold (fun x acc -> Printf.sprintf "%s\n%s" acc (f x)) m "" let rec count = function | F _ -> 1 | N l -> List.fold_left (fun acc x -> acc+count x) 0 l let opt_comb f x y = match x with None -> f y | _ -> x let rec choose = function | F x -> Some x | N l -> List.fold_left (fun acc x -> opt_comb choose acc x ) None l let is_empty = fun x -> choose x = None let to_list m = (fold (fun x acc -> x::acc) m []) let sort f m = N (List.map (fun x -> F x) (List.sort f (to_list m))) (* preserve the structure of the heap *) let filter f m = fold (fun x acc -> (if f x then return x else fail ()) >>| acc) m (N []) aac-tactics-8.18.0/src/coq.mli0000644000175000017500000001614614463022056015472 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Interface with Coq where we define some handlers for Coq's API, and we import several definitions from Coq's standard library. This general purpose library could be reused by other plugins. Some salient points: - we use Caml's module system to mimic Coq's one, and avoid cluttering the namespace; - we also provide several handlers for standard coq tactics, in order to provide a unified setting (we replace functions that modify the evar_map by functions that operate on the whole goal, and repack the modified evar_map with it). *) type tactic = unit Proofview.tactic (** {2 Getting Coq terms from the environment} *) type lazy_ref = Names.GlobRef.t Lazy.t val get_fresh : lazy_ref -> Constr.constr val get_efresh : lazy_ref -> EConstr.constr val find_global : string -> lazy_ref (** {2 General purpose functions} *) val cps_resolve_one_typeclass: ?error:Pp.t -> EConstr.types -> (EConstr.constr -> tactic) -> tactic val evar_binary: Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr val evar_relation: Environ.env -> Evd.evar_map -> EConstr.constr -> Evd.evar_map * EConstr.constr (** [cps_mk_letin name v] binds the constr [v] using a letin tactic *) val cps_mk_letin : string -> EConstr.constr -> ( EConstr.constr -> tactic) -> tactic val mk_letin : string -> EConstr.constr -> EConstr.constr Proofview.tactic val retype : EConstr.constr -> tactic val tclRETYPE : EConstr.constr -> unit Proofview.tactic val decomp_term : Evd.evar_map -> EConstr.constr -> (EConstr.constr , EConstr.types, EConstr.ESorts.t, EConstr.EInstance.t) Constr.kind_of_term (** {2 Bindings with Coq' Standard Library} *) (** Coq lists *) module List: sig (** [of_list ty l] *) val of_list:EConstr.constr ->EConstr.constr list ->EConstr.constr (** [type_of_list ty] *) val type_of_list:EConstr.constr ->EConstr.constr end (** Coq pairs *) module Pair: sig val typ: lazy_ref val pair: lazy_ref val of_pair : EConstr.constr -> EConstr.constr -> EConstr.constr * EConstr.constr -> EConstr.constr end module Option : sig val typ : lazy_ref val some : EConstr.constr -> EConstr.constr -> EConstr.constr val none : EConstr.constr -> EConstr.constr val of_option : EConstr.constr -> EConstr.constr option -> EConstr.constr end (** Coq positive numbers (pos) *) module Pos: sig val typ:lazy_ref val of_int: int ->EConstr.constr end (** Coq unary numbers (peano) *) module Nat: sig val typ:lazy_ref val of_int: int -> Constr.constr end (** Coq typeclasses *) module Classes: sig val mk_morphism: EConstr.constr -> EConstr.constr -> EConstr.constr -> EConstr.constr val mk_equivalence: EConstr.constr -> EConstr.constr -> EConstr.constr val mk_reflexive: EConstr.constr -> EConstr.constr -> EConstr.constr val mk_transitive: EConstr.constr -> EConstr.constr -> EConstr.constr end module Relation : sig type t = {carrier : EConstr.constr; r : EConstr.constr;} val make : EConstr.constr -> EConstr.constr -> t val split : t -> EConstr.constr * EConstr.constr end module Equivalence : sig type t = { carrier : EConstr.constr; eq : EConstr.constr; equivalence : EConstr.constr; } val make : EConstr.constr -> EConstr.constr -> EConstr.constr -> t val infer : Environ.env -> Evd.evar_map -> EConstr.constr -> EConstr.constr -> t * Evd.evar_map val from_relation : Environ.env -> Evd.evar_map -> Relation.t -> t * Evd.evar_map val to_relation : t -> Relation.t val split : t -> EConstr.constr * EConstr.constr * EConstr.constr end (** [match_as_equation ?context env sigma c] try to decompose c as a relation applied to two terms. *) val match_as_equation : ?context:EConstr.rel_context -> Environ.env -> Evd.evar_map -> EConstr.constr -> (EConstr.constr * EConstr.constr * Relation.t) option (** {2 Some tacticials} *) (** time the execution of a tactic *) val tclTIME : string -> tactic -> tactic (** emit debug messages to see which tactics are failing *) val tclDEBUG : string -> unit Proofview.tactic (** print the current goal *) val tclPRINT : unit Proofview.tactic (** {2 Error related mechanisms} *) val anomaly : string -> 'a val user_error : Pp.t -> 'a val warning : string -> unit (** {2 Helpers} *) (** print the current proof term *) val show_proof : Declare.Proof.t -> unit (** {2 Rewriting tactics used in aac_rewrite} *) module Rewrite : sig (** The rewriting tactics used in aac_rewrite, build as handlers of the usual [setoid_rewrite]*) (** {2 Datatypes} *) (** We keep some informations about the hypothesis, with an (informal) invariant: - [typeof hyp = typ] - [typ = forall context, body] - [body = rel left right] *) type hypinfo = { hyp : EConstr.constr; (** the actual constr corresponding to the hypothese *) hyptype : EConstr.constr; (** the type of the hypothesis *) context : EConstr.rel_context; (** the quantifications of the hypothese *) body : EConstr.constr; (** the body of the hypothese*) rel : Relation.t; (** the relation *) left : EConstr.constr; (** left hand side *) right : EConstr.constr; (** right hand side *) l2r : bool; (** rewriting from left to right *) } (** [get_hypinfo ?check_type H l2r] analyse the hypothesis H, and build the related hypinfo. Moreover, an optionnal function can be provided to check the type of every free variable of the body of the hypothesis. *) val get_hypinfo : Environ.env -> Evd.evar_map -> ?check_type:(EConstr.types -> bool) -> EConstr.constr -> l2r:bool -> hypinfo (** {2 Rewriting with bindings} The problem : Given a term to rewrite of type [H :forall xn ... x1, t], we have to instanciate the subset of [xi] of type [carrier]. [subst : (int * constr)] is the mapping the De Bruijn indices in [t] to the [constrs]. We need to handle the rest of the indexes. Two ways : - either using fresh evars and rewriting [H tn ?1 tn-2 ?2 ] - either building a term like [fun 1 2 => H tn 1 tn-2 2] Both these terms have the same type. *) (** build the constr to rewrite, with lambda abstractions *) val build : hypinfo -> (int * EConstr.constr) list -> EConstr.constr (** build the constr to rewrite, in CPS style, with evars *) (* val build_with_evar : hypinfo -> (int * EConstr.constr) list -> (EConstr.constr -> tactic) -> tactic *) (** [rewrite ?abort hypinfo subst] builds the rewriting tactic associated with the given [subst] and [hypinfo]. If [abort] is set to [true], we build [tclIDTAC] instead. *) val rewrite : ?abort:bool -> hypinfo -> (int * EConstr.constr) list -> unit Proofview.tactic end aac-tactics-8.18.0/src/matcher.ml0000644000175000017500000010213214463022056016151 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** This module defines our matching functions, modulo associativity and commutativity (AAC). The basic idea is to find a substitution [env] such that the pattern [p] instantiated by [env] is equal to [t] modulo AAC. We proceed by structural decomposition of the pattern, and try all possible non-deterministic split of the subject when needed. The function {!matcher} is limited to top-level matching, that is, the subject must make a perfect match against the pattern ([x+x] do not match [a+a+b] ). We use a search monad {!Search} to perform non-deterministic splits in an almost transparent way. We also provide a function {!subterm} for finding a match that is a subterm modulo AAC of the subject. Therefore, we are able to solve the aforementioned case [x+x] against [a+b+a]. This file is structured as follows. First, we define the search monad. Then,we define the two representations of terms (one representing the AST, and one in normal form ), and environments from variables to terms. Then, we use these parts to solve matching problem. Finally, we wrap this function {!matcher} into {!subterm} *) module Control = struct let debug = false let time = false let printing = false end module Debug = Helper.Debug (Control) open Debug module Search = Search_monad (* a handle *) type symbol = int type var = int type units = (symbol * symbol) list (* from AC/A symbols to the unit *) type ext_units = { unit_for : units; is_ac : (symbol * bool) list } exception NoUnit let get_unit units op = try List.assoc op units with | Not_found -> raise NoUnit let is_unit units op unit = List.mem (op,unit) units open Search type 'a mset = ('a * int) list let linear p = let rec ncons t l = function | 0 -> l | n -> t::ncons t l (n-1) in let rec aux = function [ ] -> [] | (t,n)::q -> let q = aux q in ncons t q n in aux p (** The module {!Terms} defines two different types for expressions. - a public type {!Terms.t} that represent abstract syntax trees of expressions with binary associative (and commutative) operators - a private type {!Terms.nf_term} that represent an equivalence class for terms that are equal modulo AAC. The constructions functions on this type ensure the property that the term is in normal form (that is, no sum can appear as a subterm of the same sum, no trailing units, etc...). *) module Terms : sig (** {1 Abstract syntax tree of terms} Terms represented using this datatype are representation of the AST of an expression. *) type t = Dot of (symbol * t * t) | Plus of (symbol * t * t) | Sym of (symbol * t array) | Var of var | Unit of symbol val equal_aac : units -> t -> t -> bool val size: t -> int (** {1 Terms in normal form} A term in normal form is the canonical representative of the equivalence class of all the terms that are equal modulo Associativity and Commutativity. Outside the {!Matcher} module, one does not need to access the actual representation of this type. *) type nf_term = private | TAC of symbol * nf_term mset | TA of symbol * nf_term list | TSym of symbol * nf_term list | TUnit of symbol | TVar of var (** {2 Constructors: we ensure that the terms are always normalised braibant - Fri 27 Aug 2010, 15:11 Moreover, we assure that we will not build empty sums or empty products, leaving this task to the caller function. } *) val mk_TAC : units -> symbol -> nf_term mset -> nf_term val mk_TA : units -> symbol -> nf_term list -> nf_term val mk_TUnit : symbol -> nf_term (** {2 Comparisons} *) val nf_term_compare : nf_term -> nf_term -> int val nf_equal : nf_term -> nf_term -> bool (** {2 Printing function} *) val sprint_nf_term : nf_term -> string (** {2 Conversion functions} *) val term_of_t : units -> t -> nf_term val t_of_term : nf_term -> t (* we could return the units here *) end = struct type t = Dot of (symbol * t * t) | Plus of (symbol * t * t) | Sym of (symbol * t array) | Var of var | Unit of symbol let rec size = function | Dot (_,x,y) | Plus (_,x,y) -> size x+ size y + 1 | Sym (_,v)-> Array.fold_left (fun acc x -> size x + acc) 1 v | _ -> 1 type nf_term = | TAC of symbol * nf_term mset | TA of symbol * nf_term list | TSym of symbol * nf_term list | TUnit of symbol | TVar of var (** {2 Constructors: we ensure that the terms are always normalised} *) (** {3 Pre constructors : These constructors ensure that sums and products are not degenerated (no trailing units)} *) let mk_TAC' units (s : symbol) l = match l with | [] -> TUnit (get_unit units s ) | [_,0] -> assert false | [t,1] -> t | _ -> TAC (s,l) let mk_TA' units (s : symbol) l = match l with | [] -> TUnit (get_unit units s ) | [t] -> t | _ -> TA (s,l) (** {2 Comparison} *) let nf_term_compare = Stdlib.compare let nf_equal a b = a = b (** [merge_ac comp l1 l2] merges two lists of terms with coefficients into one. Terms that are equal modulo the comparison function [comp] will see their arities added. *) (* This function could be improved by the use of sorted msets *) let merge_ac (compare : 'a -> 'a -> int) (l : 'a mset) (l' : 'a mset) : 'a mset = let rec aux l l'= match l,l' with | [], _ -> l' | _, [] -> l | (t,tar)::q, (t',tar')::q' -> begin match compare t t' with | 0 -> ( t,tar+tar'):: aux q q' | -1 -> (t, tar):: aux q l' | _ -> (t', tar'):: aux l q' end in aux l l' (** [merge_map f l] uses the combinator [f] to combine the head of the list [l] with the merge_maped tail of [l] *) let rec merge_map (f : 'a -> 'b list -> 'b list) (l : 'a list) : 'b list = match l with | [] -> [] | t::q -> f t (merge_map f q) (** This function has to deal with the arities *) let merge (l : nf_term mset) (l' : nf_term mset) : nf_term mset= merge_ac nf_term_compare l l' let extract_A units s t = match t with | TA (s',l) when s' = s -> l | TUnit u when is_unit units s u -> [] | _ -> [t] let extract_AC units s (t,ar) : nf_term mset = match t with | TAC (s',l) when s' = s -> List.map (fun (x,y) -> (x,y*ar)) l | TUnit u when is_unit units s u -> [] | _ -> [t,ar] (** {3 Constructors of {!nf_term}}*) let mk_TAC units (s : symbol) (l : (nf_term *int) list) = mk_TAC' units s (merge_map (fun u l -> merge (extract_AC units s u) l) l) let mk_TA units s l = mk_TA' units s (merge_map (fun u l -> (extract_A units s u) @ l) l) let mk_TSym s l = TSym (s,l) let mk_TVar v = TVar v let mk_TUnit s = TUnit s (** {2 Printing function} *) let print_binary_list (single : 'a -> string) (unit : string) (binary : string -> string -> string) (l : 'a list) = let rec aux l = match l with [] -> unit | [t] -> single t | t::q -> let r = aux q in Printf.sprintf "%s" (binary (single t) r) in aux l let sprint_ac (single : 'a -> string) (l : 'a mset) = (print_binary_list (fun (x,t) -> if t = 1 then single x else Printf.sprintf "%i*%s" t (single x) ) "0" (fun x y -> x ^ " , " ^ y) l ) let print_symbol single s l = match l with [] -> Printf.sprintf "%i" s | _ -> Printf.sprintf "%i(%s)" s (print_binary_list single "" (fun x y -> x ^ "," ^ y) l) let print_ac single s l = Printf.sprintf "[%s:AC]{%s}" (string_of_int s ) (sprint_ac single l ) let print_a single s l = Printf.sprintf "[%s:A]{%s}" (string_of_int s) (print_binary_list single "1" (fun x y -> x ^ " , " ^ y) l) let rec sprint_nf_term = function | TSym (s,l) -> print_symbol sprint_nf_term s l | TAC (s,l) -> print_ac sprint_nf_term s l | TA (s,l) -> print_a sprint_nf_term s l | TVar v -> Printf.sprintf "x%i" v | TUnit s -> Printf.sprintf "unit%i" s (** {2 Conversion functions} *) (* rebuilds a tree out of a list, under the assumption that the list is not empty *) let binary_of_list f comb l = let l = List.rev l in let rec aux = function | [] -> assert false | [t] -> f t | t::q -> comb (aux q) (f t) in aux l let term_of_t units : t -> nf_term = let rec term_of_t = function | Dot (s,l,r) -> let l = term_of_t l in let r = term_of_t r in mk_TA units s [l;r] | Plus (s,l,r) -> let l = term_of_t l in let r = term_of_t r in mk_TAC units s [l,1;r,1] | Unit x -> mk_TUnit x | Sym (s,t) -> let t = Array.to_list t in let t = List.map term_of_t t in mk_TSym s t | Var i -> mk_TVar ( i) in term_of_t let rec t_of_term : nf_term -> t = function | TAC (s,l) -> (binary_of_list t_of_term (fun l r -> Plus ( s,l,r)) (linear l) ) | TA (s,l) -> (binary_of_list t_of_term (fun l r -> Dot ( s,l,r)) l ) | TSym (s,l) -> let v = Array.of_list l in let v = Array.map (t_of_term) v in Sym ( s,v) | TVar x -> Var x | TUnit s -> Unit s let equal_aac units x y = nf_equal (term_of_t units x) (term_of_t units y) end (** Terms environments defined as association lists from variables to terms in normal form {! Terms.nf_term} *) module Subst : sig type t val find : t -> var -> Terms.nf_term option val add : t -> var -> Terms.nf_term -> t val empty : t val instantiate : t -> Terms.t -> Terms.t val sprint : t -> string val to_list : t -> (var*Terms.t) list end = struct open Terms (** Terms environments, with nf_terms, to avoid costly conversions of {!Terms.nf_terms} to {!Terms.t}, that will be mostly discarded*) type t = (var * nf_term) list let find : t -> var -> nf_term option = fun t x -> try Some (List.assoc x t) with | _ -> None let add t x v = (x,v) :: t let empty = [] let sprint (l : t) = match l with | [] -> Printf.sprintf "Empty environment\n" | _ -> let s = List.fold_left (fun acc (x,y) -> Printf.sprintf "%sX%i -> %s\n" acc x (sprint_nf_term y) ) "" (List.rev l) in Printf.sprintf "%s\n%!" s (** [instantiate] is an homomorphism except for the variables*) let instantiate (t: t) (x:Terms.t) : Terms.t = let rec aux = function | Unit _ as x -> x | Sym (s,t) -> Sym (s,Array.map aux t) | Plus (s,l,r) -> Plus (s, aux l, aux r) | Dot (s,l,r) -> Dot (s, aux l, aux r) | Var i -> begin match find t i with | None -> CErrors.user_err (Pp.strbrk "aac_tactics: instantiate failure") | Some x -> t_of_term x end in aux x let to_list t = List.map (fun (x,y) -> x,Terms.t_of_term y) t end (******************) (* MATCHING UTILS *) (******************) open Terms (** Since most of the folowing functions require an extra parameter, the units, we package them in a module. This functor will then be applied to a module containing the units, in the exported functions. *) module M (X : sig val units : units val is_ac : (symbol * bool) list val strict : bool (* variables cannot be instantiated with units *) end) = struct open X let mk_TAC s l = mk_TAC units s l let mk_TA s l = mk_TA units s l let mk_TAC' s l = try return( mk_TAC s l) with _ -> fail () let mk_TA' s l = try return( mk_TA s l) with _ -> fail () (** First, we need to be able to perform non-deterministic choice of term splitting to satisfy a pattern. Indeed, we want to show that: (x+a*b)*c <= a*b*c *) let a_nondet_split_raw t : ('a list * 'a list) m = let rec aux l l' = match l' with | [] -> return ( l,[]) | t::q -> return ( l,l' ) >>| aux (l @ [t]) q in aux [] t (** Same as the previous [a_nondet_split], but split the list in 3 parts *) let a_nondet_middle t : ('a list * 'a list * 'a list) m = a_nondet_split_raw t >> (fun (left, right) -> a_nondet_split_raw left >> (fun (left, middle) -> return (left, middle, right)) ) (** Non deterministic splits of ac lists *) let dispatch f n = let rec aux k = if k = 0 then return (f n 0) else return (f (n-k) k) >>| aux (k-1) in aux (n ) let add_with_arith x ar l = if ar = 0 then l else (x,ar) ::l let ac_nondet_split_raw (l : 'a mset) : ('a mset * 'a mset) m = let rec aux = function | [] -> return ([],[]) | (t,tar)::q -> aux q >> (fun (left,right) -> dispatch (fun arl arr -> add_with_arith t arl left, add_with_arith t arr right ) tar ) in aux l let a_nondet_split current t : (nf_term * nf_term list) m= a_nondet_split_raw t >> (fun (l,r) -> if strict && (l=[]) then fail() else mk_TA' current l >> fun t -> return (t, r) ) let ac_nondet_split current t : (nf_term * nf_term mset) m= ac_nondet_split_raw t >> (fun (l,r) -> if strict && (l=[]) then fail() else mk_TAC' current l >> fun t -> return (t, r) ) (** Try to affect the variable [x] to each left factor of [t]*) let var_a_nondet_split env current x t = a_nondet_split current t >> (fun (t,res) -> return ((Subst.add env x t), res) ) (** Try to affect variable [x] to _each_ subset of t. *) let var_ac_nondet_split (current: symbol) env (x : var) (t : nf_term mset) : (Subst.t * (nf_term mset)) m = ac_nondet_split current t >> (fun (t,res) -> return ((Subst.add env x t), res) ) (** See the term t as a given AC symbol. Unwrap the first constructor if necessary *) let get_AC (s : symbol) (t : nf_term) : (nf_term *int) list = match t with | TAC (s',l) when s' = s -> l | TUnit u when is_unit units s u -> [] | _ -> [t,1] (** See the term t as a given A symbol. Unwrap the first constructor if necessary *) let get_A (s : symbol) (t : nf_term) : nf_term list = match t with | TA (s',l) when s' = s -> l | TUnit u when is_unit units s u -> [] | _ -> [t] (** See the term [t] as an symbol [s]. Fail if it is not such symbol. *) let get_Sym s t = match t with | TSym (s',l) when s' = s -> return l | _ -> fail () (*************) (* A Removal *) (*************) (** We remove the left factor v in a term list. This function runs linearly with respect to the size of the first pattern symbol *) let left_factor current (v : nf_term) (t : nf_term list) = let rec aux a b = match a,b with | t::q , t' :: q' when nf_equal t t' -> aux q q' | [], q -> return q | _, _ -> fail () in match v with | TA (s,l) when s = current -> aux l t | TUnit u when is_unit units current u -> return t | _ -> begin match t with | [] -> fail () | t::q -> if nf_equal v t then return q else fail () end (**************) (* AC Removal *) (**************) (** {!pick_sym} gather all elements of a list that satisfies a predicate, and combine them with the residual of the list. That is, each element of the residual contains exactly one element less than the original term. TODO : This function not as efficient as it could be, using a proper data-structure *) let pick_sym (s : symbol) (t : nf_term mset ) = let rec aux front back = match back with | [] -> fail () | (t,tar)::q -> begin match t with | TSym (s',v') when s = s' -> let back = if tar > 1 then (t,tar -1) ::q else q in return (v' , List.rev_append front back ) >>| aux ((t,tar)::front) q | _ -> aux ((t,tar)::front) q end in aux [] t (** We have to check if we are trying to remove a unit from a term. Could also be located in Terms*) let is_unit_AC s t = try nf_equal t (mk_TAC s []) with | NoUnit -> false let is_same_AC s t : nf_term mset option= match t with TAC (s',l) when s = s' -> Some l | _ -> None (** We want to remove the term [v] from the term list [t] under an AC symbol *) let single_AC_factor (s : symbol) (v : nf_term) v_ar (t : nf_term mset) : (nf_term mset) m = let rec aux front back = match back with | [] -> fail () | (t,tar)::q -> begin if nf_equal v t then match () with | _ when tar < v_ar -> fail () | _ when tar = v_ar -> return (List.rev_append front q) | _ -> return (List.rev_append front ((t,tar-v_ar)::q)) else aux ((t,tar) :: front) q end in if is_unit_AC s v then return t else aux [] t (* Remove a constant from a mset. If this constant is also a mset for the same symbol, we remove every elements, one at a time (and we do care of the arities) *) let factor_AC (s : symbol) (v: nf_term) (t : nf_term mset) : ( nf_term mset ) m = match is_same_AC s v with | None -> single_AC_factor s v 1 t | Some l -> (* We are trying to remove an AC factor *) List.fold_left (fun acc (v,v_ar) -> acc >> (single_AC_factor s v v_ar) ) (return t) l (** [tri_fold f l acc] folds on the list [l] and give to f the beginning of the list in reverse order, the considered element, and the last part of the list as an exemple, on the list [1;2;3;4], we get the trace f () [] 1 [2; 3; 4] f () [1] 2 [3; 4] f () [2;1] 3 [ 4] f () [3;2;1] 4 [] it is the duty of the user to reverse the front if needed *) let tri_fold f (l : 'a list) (acc : 'b)= match l with [] -> acc | _ -> let _,_,acc = List.fold_left (fun acc (t : 'a) -> let l,r,acc = acc in let r = List.tl r in t::l,r,f acc l t r ) ([], l,acc) l in acc (* let test = tri_fold (fun acc l t r -> (l,t,r) :: acc) [1;2;3;4] [] *) (*****************************) (* ENUMERATION DES POSITIONS *) (*****************************) (** The pattern is a unit: we need to try to make it appear at each position. We do not need to go further with a real matching, since the match should be trivial. Hence, we proceed recursively to enumerate all the positions. *) module Positions = struct let a (l : 'a list) : ('a list * 'a * 'a list) m = let rec aux left right : ('a list * 'a * 'a list) m = match right with | [] -> assert false | [t] -> return (left,t,[]) | t::q -> aux (left@[t]) q >>| return (left,t,q) in aux [] l end let build_ac (current : symbol) (context : nf_term mset) (p : t) : t m= if context = [] then return p else mk_TAC' current context >> fun t -> return (Plus (current,t_of_term t,p)) let build_a (current : symbol) (left : nf_term list) (right : nf_term list) (p : t) : t m= let right_pat p = if right = [] then return p else mk_TA' current right >> fun t -> return (Dot (current,p,t_of_term t)) in let left_pat p= if left = [] then return p else mk_TA' current left >> fun t -> return (Dot (current,t_of_term t,p)) in right_pat p >> left_pat >> (fun p -> return p) let conts (hole : t) (l : symbol list) p : t m = let p = t_of_term p in (* - aller chercher les symboles ac et les symboles a - construire pour chaque * * + / \ / \ / \ 1 p p 1 p 1 *) let ac,a = List.partition (fun s -> List.assoc s is_ac) l in let acc = fail () in let acc = List.fold_left (fun acc s -> acc >>| return (Plus (s,p,hole)) ) acc ac in let acc = List.fold_left (fun acc s -> acc >>| return (Dot (s,p,hole)) >>| return (Dot (s,hole,p)) ) acc a in acc (** Return the same thing as subterm : - The size of the context - The context - A collection of substitutions (here == return Subst.empty) *) let unit_subterm (t : nf_term) (unit : symbol) (hole : t): (int * t * Subst.t m) m = let symbols = List.fold_left (fun acc (ac,u) -> if u = unit then ac :: acc else acc ) [] units in (* make a unit appear at each strict sub-position of the term*) let rec positions (t : nf_term) : t m = match t with (* with a final unit at the end *) | TAC (s,l) -> let symbols' = List.filter (fun x -> x <> s) symbols in ( ac_nondet_split_raw l >> (fun (l,r) -> if l = [] || r = [] then fail () else ( match r with | [p,1] -> positions p >>| conts hole symbols' p | _ -> mk_TAC' s r >> conts hole symbols' ) >> build_ac s l )) | TA (s,l) -> let symbols' = List.filter (fun x -> x <> s) symbols in ( (* first the other symbols, and then the more simple case of this particular symbol *) a_nondet_middle l >> (fun (l,m,r) -> (* meant to break the symmetry *) if (l = [] && r = []) then fail () else ( match m with | [p] -> positions p >>| conts hole symbols' p | _ -> mk_TA' s m >> conts hole symbols' ) >> build_a s l r )) >>| ( if List.mem s symbols then begin match l with | [a] -> assert false | [a;b] -> build_a s [a] [b] (hole) | _ -> (* on ne construit que les elements interieurs, d'ou la disymetrie *) (Positions.a l >> (fun (left,p,right) -> if left = [] then fail () else (build_a s left right (Dot (s,hole,t_of_term p))))) end else fail () ) | TSym (s,l) -> tri_fold (fun acc l t r -> ((positions t) >> (fun (p) -> let l = List.map t_of_term l in let r = List.map t_of_term r in return (Sym (s, Array.of_list (List.rev_append l (p::r)))) )) >>| ( conts hole symbols t >> (fun (p) -> let l = List.map t_of_term l in let r = List.map t_of_term r in return (Sym (s, Array.of_list (List.rev_append l (p::r)))) ) ) >>| acc ) l (fail()) | TVar x -> assert false | TUnit x when x = unit -> return (hole) | TUnit x as t -> conts hole symbols t in (positions t >>| (match t with | TSym _ -> conts hole symbols t | TAC (s,l) -> conts hole symbols t | TA (s,l) -> conts hole symbols t | _ -> fail()) ) >> fun (p) -> return (Terms.size p,p,return Subst.empty) (************) (* Matching *) (************) (** {!matching} is the generic matching judgement. Each time a non-deterministic split is made, we have to come back to this one. {!matchingSym} is used to match two applications that have the same (free) head-symbol. {!matchingAC} is used to match two sums (with the subtlety that [x+y] matches [f a] which is a function application or [a*b] which is a product). {!matchingA} is used to match two products (with the subtlety that [x*y] matches [f a] which is a function application, or [a+b] which is a sum). *) let matching : Subst.t -> nf_term -> nf_term -> Subst.t Search.m= let rec matching env (p : nf_term) (t: nf_term) : Subst.t Search.m= match p with | TAC (s,l) -> let l = linear l in matchingAC env s l (get_AC s t) | TA (s,l) -> matchingA env s l (get_A s t) | TSym (s,l) -> (get_Sym s t) >> (fun t -> matchingSym env l t) | TVar x -> begin match Subst.find env x with | None -> return (Subst.add env x t) | Some v -> if nf_equal v t then return env else fail () end | TUnit s -> if nf_equal p t then return env else fail () and matchingAC (env : Subst.t) (current : symbol) (l : nf_term list) (t : (nf_term *int) list) = match l with | TSym (s,v):: q -> pick_sym s t >> (fun (v',t') -> matchingSym env v v' >> (fun env -> matchingAC env current q t')) | TAC (s,v)::q when s = current -> assert false | TVar x:: q -> (* This is an optimization *) begin match Subst.find env x with | None -> (var_ac_nondet_split current env x t) >> (fun (env,residual) -> matchingAC env current q residual) | Some v -> (factor_AC current v t) >> (fun residual -> matchingAC env current q residual) end | TUnit s as v :: q -> (* this is an optimization *) (factor_AC current v t) >> (fun residual -> matchingAC env current q residual) | h :: q ->(* PAC =/= curent or PA or unit for this symbol*) (ac_nondet_split current t) >> (fun (t,right) -> matching env h t >> ( fun env -> matchingAC env current q right ) ) | [] -> if t = [] then return env else fail () and matchingA (env : Subst.t) (current : symbol) (l : nf_term list) (t : nf_term list) = match l with | TSym (s,v) :: l -> begin match t with | TSym (s',v') :: r when s = s' -> (matchingSym env v v') >> (fun env -> matchingA env current l r) | _ -> fail () end | TA (s,v) :: l when s = current -> assert false | TVar x :: l -> begin match Subst.find env x with | None -> debug (Printf.sprintf "var %i (%s)" x (let b = Buffer.create 21 in List.iter (fun t -> Buffer.add_string b ( Terms.sprint_nf_term t)) t; Buffer.contents b )); var_a_nondet_split env current x t >> (fun (env,residual)-> debug (Printf.sprintf "pl %i %i" x(List.length residual)); matchingA env current l residual) | Some v -> (left_factor current v t) >> (fun residual -> matchingA env current l residual) end | TUnit s as v :: q -> (* this is an optimization *) (left_factor current v t) >> (fun residual -> matchingA env current q residual) | h :: l -> a_nondet_split current t >> (fun (t,r) -> matching env h t >> (fun env -> matchingA env current l r) ) | [] -> if t = [] then return env else fail () and matchingSym (env : Subst.t) (l : nf_term list) (t : nf_term list) = List.fold_left2 (fun acc p t -> acc >> (fun env -> matching env p t)) (return env) l t in fun env l r -> let _ = debug (Printf.sprintf "pattern :%s\nterm :%s\n%!" (Terms.sprint_nf_term l) (Terms.sprint_nf_term r)) in let m = matching env l r in let _ = debug (Printf.sprintf "count %i" (Search.count m)) in m (** [unitifiable p : Subst.t m] *) let unitifiable p : (symbol * Subst.t m) m = let m = List.fold_left (fun acc (_,unit) -> acc >>| let m = matching Subst.empty p (mk_TUnit unit) in if Search.is_empty m then fail () else begin return (unit,m) end ) (fail ()) units in m ;; let nullifiable p = let nullable = not strict in let has_unit s = try let _ = get_unit units s in true with NoUnit -> false in let rec aux = function | TA (s,l) -> has_unit s && List.for_all (aux) l | TAC (s,l) -> has_unit s && List.for_all (fun (x,n) -> aux x) l | TSym _ -> false | TVar _ -> nullable | TUnit _ -> true in aux p let unit_warning p ~nullif ~unitif = assert ((Search.is_empty unitif) || nullif); if not (Search.is_empty unitif) then begin Feedback.msg_warning (Pp.str "[aac_tactics] This pattern can be instantiated to match units, some solutions can be missing"); end ;; (***********) (* Subterm *) (***********) (** [subterm] solves a sub-term pattern matching. This function is more high-level than {!matcher}, thus takes {!t} as arguments rather than terms in normal form {!nf_term}. We use three mutually recursive functions {!subterm}, {!subterm_AC}, {!subterm_A} to find the matching subterm, making non-deterministic choices to split the term into a context and an intersting sub-term. Intuitively, the only case in which we have to go in depth is when we are left with a sub-term that is atomic. Indeed, rewriting [H: b = c |- a+b+a = a+a+c], we do not want to find recursively the sub-terms of [a+b] and [b+a], since they will overlap with the sub-terms of [a+b+a]. We rebuild the context on the fly, leaving the variables in the pattern uninstantiated. We do so in order to allow interaction with the user, to choose the env. Strange patterms like x*y*x can be instantiated by nothing, inside a product. Therefore, we need to check that all the term is not going into the context. With proper support for interaction with the user, we should lift these tests. However, at the moment, they serve as heuristics to return "interesting" matchings *) let return_non_empty raw_p m = if is_empty m then fail () else return (raw_p ,m) let subterm (raw_p:t) (raw_t:t): (int * t * Subst.t m) m= let _ = debug (String.make 40 '=') in let p = term_of_t units raw_p in let t = term_of_t units raw_t in let nullif = nullifiable p in let unitif = unitifiable p in let _ = unit_warning p ~nullif ~unitif in let _ = debug (Printf.sprintf "%s" (Terms.sprint_nf_term p)) in let _ = debug (Printf.sprintf "%s" (Terms.sprint_nf_term t)) in let filter_right current right (p,m) = if right = [] then return (p,m) else mk_TAC' current right >> fun t -> return (Plus (current,p,t_of_term t),m) in let filter_middle current left right (p,m) = let right_pat p = if right = [] then return p else mk_TA' current right >> fun t -> return (Dot (current,p,t_of_term t)) in let left_pat p= if left = [] then return p else mk_TA' current left >> fun t -> return (Dot (current,t_of_term t,p)) in right_pat p >> left_pat >> (fun p -> return (p,m)) in let rec subterm (t:nf_term) : (t * Subst.t m) m= match t with | TAC (s,l) -> ((ac_nondet_split_raw l) >> (fun (left,right) -> (subterm_AC s left) >> (filter_right s right) )) | TA (s,l) -> (a_nondet_middle l) >> (fun (left, middle, right) -> (subterm_A s middle) >> (filter_middle s left right) ) | TSym (s, l) -> let init = return_non_empty raw_p (matching Subst.empty p t) in tri_fold (fun acc l t r -> ((subterm t) >> (fun (p,m) -> let l = List.map t_of_term l in let r = List.map t_of_term r in let p = Sym (s, Array.of_list (List.rev_append l (p::r))) in return (p,m) )) >>| acc ) l init | TVar x -> assert false (* this case is superseded by the later disjunction *) | TUnit s -> fail () and subterm_AC s tl = match tl with [x,1] -> subterm x | _ -> mk_TAC' s tl >> fun t -> return_non_empty raw_p (matching Subst.empty p t) and subterm_A s tl = match tl with [x] -> subterm x | _ -> mk_TA' s tl >> fun t -> return_non_empty raw_p (matching Subst.empty p t) in match p with | TUnit unit -> unit_subterm t unit raw_p | _ when not (Search.is_empty unitif) -> let unit_matches = Search.fold (fun (unit,inst) acc -> Search.fold (fun subst acc' -> let m = unit_subterm t unit (Subst.instantiate subst raw_p) in m>>| acc' ) inst acc ) unitif (fail ()) in let nullifies (t : Subst.t) = List.for_all (fun (_,x) -> List.exists (fun (_,y) -> Unit y = x ) units ) (Subst.to_list t) in let nonunit_matches = subterm t >> ( fun (p,m) -> let m = Search.filter (fun subst -> not( nullifies subst)) m in if Search.is_empty m then fail () else return (Terms.size p,p,m) ) in unit_matches >>| nonunit_matches | _ -> (subterm t >> fun (p,m) -> return (Terms.size p,p,m)) end (* The functions we export, handlers for the previous ones. Some debug information also *) let subterm ?(strict = false) units raw t = let module M = M (struct let is_ac = units.is_ac let units = units.unit_for let strict = strict end) in let sols = time (M.subterm raw) t "%fs spent in subterm (including matching)\n" in debug (Printf.sprintf "%i possible solution(s)\n" (Search.fold (fun (_,_,envm) acc -> count envm + acc) sols 0)); sols let matcher ?(strict = false) units p t = let module M = M (struct let is_ac = units.is_ac let units = units.unit_for let strict = false end) in let units = units.unit_for in let sols = time (fun (p,t) -> let p = (Terms.term_of_t units p) in let t = (Terms.term_of_t units t) in M.matching Subst.empty p t) (p,t) "%fs spent in the matcher\n" in debug (Printf.sprintf "%i solutions\n" (count sols)); sols aac-tactics-8.18.0/src/theory.ml0000644000175000017500000011015614463022056016045 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Constr from the theory of this particular development The inner-working of this module is highly correlated with the particular structure of {b AAC_rewrite.v}, therefore, it should be of little interest to most readers. *) open EConstr module Control = struct let printing = true let debug = false let time = false end module Debug = Helper.Debug (Control) open Debug (** {1 HMap : Specialized Hashtables based on constr} *) (* TODO module HMap = Hashtbl, du coup ? *) module HMap = Hashtbl.Make(Constr) module Stubs = struct (** The constants from the inductive type *) let _Tty = Coq.find_global "internal.T" let rsum = Coq.find_global "internal.sum" let rprd = Coq.find_global "internal.prd" let rsym = Coq.find_global "internal.sym" let runit = Coq.find_global "internal.unit" let vnil = Coq.find_global "internal.vnil" let vcons = Coq.find_global "internal.vcons" let eval = Coq.find_global "internal.eval" let decide_thm = Coq.find_global "internal.decide" let lift_normalise_thm = Coq.find_global "internal.lift_normalise" let lift = Coq.find_global "internal.AAC_lift" let lift_proj_equivalence= Coq.find_global "internal.aac_lift_equivalence" let lift_transitivity_left = Coq.find_global "internal.lift_transitivity_left" let lift_transitivity_right = Coq.find_global "internal.lift_transitivity_right" let lift_reflexivity = Coq.find_global "internal.lift_reflexivity" end module Classes = struct module Associative = struct let typ = Coq.find_global "classes.Associative" let ty (rlt : Coq.Relation.t) (value : constr) = mkApp (Coq.get_efresh typ, [| rlt.Coq.Relation.carrier; rlt.Coq.Relation.r; value |] ) let infer env sigma rlt value = let ty = ty rlt value in Typeclasses.resolve_one_typeclass env sigma ty end module Commutative = struct let typ = Coq.find_global "classes.Commutative" let ty (rlt : Coq.Relation.t) (value : constr) = mkApp (Coq.get_efresh typ, [| rlt.Coq.Relation.carrier; rlt.Coq.Relation.r; value |] ) end module Idempotent = struct let typ = Coq.find_global "classes.Idempotent" let ty (rlt : Coq.Relation.t) (value : constr) = mkApp (Coq.get_efresh typ, [| rlt.Coq.Relation.carrier; rlt.Coq.Relation.r; value |] ) end module Proper = struct let typeof = Coq.find_global "internal.sym.type_of" let relof = Coq.find_global "internal.sym.rel_of" let mk_typeof : Coq.Relation.t -> int -> constr = fun rlt n -> let x = rlt.Coq.Relation.carrier in mkApp (Coq.get_efresh typeof, [| x ; of_constr (Coq.Nat.of_int n) |]) let mk_relof : Coq.Relation.t -> int -> constr = fun rlt n -> let (x,r) = Coq.Relation.split rlt in mkApp (Coq.get_efresh relof, [| x;r ; of_constr (Coq.Nat.of_int n) |]) let ty rlt op ar = let typeof = mk_typeof rlt ar in let relof = mk_relof rlt ar in Coq.Classes.mk_morphism typeof relof op let infer env sigma rlt op ar = let ty = ty rlt op ar in Typeclasses.resolve_one_typeclass env sigma ty end module Unit = struct let typ = Coq.find_global "classes.Unit" let ty (rlt : Coq.Relation.t) (value : constr) (unit : constr)= mkApp (Coq.get_efresh typ, [| rlt.Coq.Relation.carrier; rlt.Coq.Relation.r; value; unit |] ) end end (* Non empty lists *) module NEList = struct let nil = Coq.find_global "nelist.nil" let cons = Coq.find_global "nelist.cons" let cons ty h t = mkApp (Coq.get_efresh cons, [| ty; h ; t |]) let nil ty x = (mkApp (Coq.get_efresh nil, [| ty ; x|])) let rec of_list ty = function | [] -> invalid_arg "NELIST" | [x] -> nil ty x | t::q -> cons ty t (of_list ty q) end (** a [mset] is a ('a * pos) list *) let mk_mset ty (l : (constr * int) list) = let pos = Coq.get_efresh Coq.Pos.typ in let pair (x : constr) (ar : int) = Coq.Pair.of_pair ty pos (x, Coq.Pos.of_int ar) in let pair_ty = mkApp (Coq.get_efresh Coq.Pair.typ,[| ty ; pos|]) in let rec aux = function | [ ] -> assert false | [x,ar] -> NEList.nil pair_ty (pair x ar) | (t,ar)::q -> NEList.cons pair_ty (pair t ar) (aux q) in aux l module Sigma = struct let sigma_empty = Coq.find_global "sigma.empty" let sigma_add = Coq.find_global "sigma.add" let sigma_get = Coq.find_global "sigma.get" let add ty n x map = mkApp (Coq.get_efresh sigma_add,[|ty; n; x ; map|]) let empty ty = mkApp (Coq.get_efresh sigma_empty,[|ty |]) let to_fun ty null map = mkApp (Coq.get_efresh sigma_get, [|ty;null;map|]) let of_list ty null l = match l with | (_,t)::q -> let map = List.fold_left (fun acc (i,t) -> assert (i > 0); add ty (Coq.Pos.of_int i) ( t) acc) (empty ty) q in to_fun ty (t) map | [] -> debug "of_list empty" ; to_fun ty (null) (empty ty) end module Sym = struct type pack = {ar: Constr.t; value: Constr.t ; morph: Constr.t} let typ = Coq.find_global "sym.pack" let mkPack = Coq.find_global "sym.mkPack" let null = Coq.find_global "sym.null" let mk_pack (rlt: Coq.Relation.t) s = let (x,r) = Coq.Relation.split rlt in mkApp (Coq.get_efresh mkPack, [|x;r; EConstr.of_constr s.ar;EConstr.of_constr s.value;EConstr.of_constr s.morph|]) let null rlt = let x = rlt.Coq.Relation.carrier in let r = rlt.Coq.Relation.r in mkApp (Coq.get_efresh null, [| x;r;|]) let mk_ty : Coq.Relation.t -> constr = fun rlt -> let (x,r) = Coq.Relation.split rlt in mkApp (Coq.get_efresh typ, [| x; r|] ) end module Bin =struct type pack = {value : Constr.t; compat : Constr.t; assoc : Constr.t; comm : Constr.t option; idem : Constr.t option; } let typ = Coq.find_global "bin.pack" let mkPack = Coq.find_global "bin.mkPack" let mk_pack: Coq.Relation.t -> pack -> constr = fun (rlt) s -> let (x,r) = Coq.Relation.split rlt in let comm_ty = Classes.Commutative.ty rlt (EConstr.of_constr s.value) in let idem_ty = Classes.Idempotent.ty rlt (EConstr.of_constr s.value) in mkApp (Coq.get_efresh mkPack , [| x ; r; EConstr.of_constr s.value; EConstr.of_constr s.compat ; EConstr.of_constr s.assoc; Coq.Option.of_option comm_ty (Option.map EConstr.of_constr s.comm); Coq.Option.of_option idem_ty (Option.map EConstr.of_constr s.idem) |]) let mk_ty : Coq.Relation.t -> constr = fun rlt -> let (x,r) = Coq.Relation.split rlt in mkApp (Coq.get_efresh typ, [| x; r|] ) end module Unit = struct let unit_of_ty = Coq.find_global "internal.unit_of" let unit_pack_ty = Coq.find_global "internal.unit_pack" let mk_unit_of = Coq.find_global "internal.mk_unit_for" let mk_unit_pack = Coq.find_global "internal.mk_unit_pack" type unit_of = { uf_u : Constr.t; (* u *) uf_idx : Constr.t; uf_desc : Constr.t; (* Unit R (e_bin uf_idx) u *) } type pack = { u_value : constr; (* X *) u_desc : (unit_of) list (* unit_of u_value *) } let ty_unit_of rlt e_bin u = let (x,r) = Coq.Relation.split rlt in mkApp ( Coq.get_efresh unit_of_ty, [| x; r; e_bin; u |]) let ty_unit_pack rlt e_bin = let (x,r) = Coq.Relation.split rlt in mkApp (Coq.get_efresh unit_pack_ty, [| x; r; e_bin |]) let mk_unit_of rlt e_bin u unit_of = let (x,r) = Coq.Relation.split rlt in mkApp (Coq.get_efresh mk_unit_of , [| x; r; e_bin ; u; EConstr.of_constr unit_of.uf_idx; EConstr.of_constr unit_of.uf_desc |]) let mk_pack rlt e_bin pack : constr = let (x,r) = Coq.Relation.split rlt in let ty = ty_unit_of rlt e_bin pack.u_value in let mk_unit_of = mk_unit_of rlt e_bin pack.u_value in let u_desc =Coq.List.of_list ( ty ) (List.map mk_unit_of pack.u_desc) in mkApp (Coq.get_efresh mk_unit_pack, [|x;r; e_bin ; pack.u_value; u_desc |]) let default x : pack = { u_value = x; u_desc = [] } end let anomaly msg = CErrors.anomaly ~label:"aac_tactics" (Pp.str msg) let user_error msg = CErrors.user_err Pp.(strbrk "aac_tactics: " ++ msg) module Trans = struct (** {1 From Coq to Abstract Syntax Trees (AST)} This module provides facilities to interpret a Coq term with arbitrary operators as an abstract syntax tree. Considering an application, we try to infer instances of our classes. We consider that [A] operators are coarser than [AC] operators, which in turn are coarser than raw morphisms. That means that [List.append], of type [(A : Type) -> list A -> list A -> list A] can be understood as an [A] operator. During this reification, we gather some informations that will be used to rebuild Coq terms from AST ( type {!envs}) We use a main hash-table from [constr] to [pack], in order to discriminate the various constructors. All these are mixed in order to improve on the number of comparisons in the tables *) (* 'a * (unit, op_unit) option *) type 'a with_unit = 'a * (Unit.unit_of) option type pack = (* used to infer the AC/A structure in the first pass {!Gather} *) | Bin of Bin.pack with_unit (* will only be used in the second pass : {!Parse}*) | Sym of Sym.pack | Unit of Constr.t (* to avoid confusion in bloom *) module PackHash = struct open Hashset.Combine type t = pack let eq_sym_pack p1 p2 = let open Sym in Constr.equal p1.ar p2.ar && Constr.equal p1.value p2.value && Constr.equal p1.morph p2.morph let hash_sym_pack p = let open Sym in combine3 (Constr.hash p.ar) (Constr.hash p.value) (Constr.hash p.morph) let eq_bin_pack p1 p2 = let open Bin in Constr.equal p1.value p2.value && Constr.equal p1.compat p2.compat && Constr.equal p1.assoc p2.assoc && Option.equal Constr.equal p1.comm p2.comm && Option.equal Constr.equal p1.idem p2.idem let hash_bin_pack p = let open Bin in combine5 (Constr.hash p.value) (Constr.hash p.compat) (Constr.hash p.assoc) (Option.hash Constr.hash p.comm) (Option.hash Constr.hash p.idem) let eq_unit_of u1 u2 = let open Unit in Constr.equal u1.uf_u u2.uf_u && Constr.equal u1.uf_idx u2.uf_idx && Constr.equal u1.uf_desc u2.uf_desc let hash_unit_of u = let open Unit in combine3 (Constr.hash u.uf_u) (Constr.hash u.uf_idx) (Constr.hash u.uf_desc) let equal p1 p2 = match p1, p2 with | Bin (p1, o1), Bin (p2, o2) -> eq_bin_pack p1 p2 && Option.equal eq_unit_of o1 o2 | Sym p1, Sym p2 -> eq_sym_pack p1 p2 | Unit c1, Unit c2 -> Constr.equal c1 c2 | _ -> false let hash p = match p with | Bin (p, o) -> combinesmall 1 (combine (hash_bin_pack p) (Option.hash hash_unit_of o)) | Sym p -> combinesmall 2 (hash_sym_pack p) | Unit c -> combinesmall 3 (Constr.hash c) end module PackTable = Hashtbl.Make(PackHash) (** discr is a map from {!constr} to {!pack}. [None] means that it is not possible to instantiate this partial application to an interesting class. [Some x] means that we found something in the past. This means in particular that a single [constr] cannot be two things at the same time. The field [bloom] allows to give a unique number to each class we found. *) type envs = { discr : (pack option) HMap.t ; bloom : int PackTable.t; bloom_back : (int, pack ) Hashtbl.t; bloom_next : int ref; } let empty_envs () = { discr = HMap.create 17; bloom = PackTable.create 17; bloom_back = Hashtbl.create 17; bloom_next = ref 1; } let add_bloom envs pack = if PackTable.mem envs.bloom pack then () else let x = ! (envs.bloom_next) in PackTable.add envs.bloom pack x; Hashtbl.add envs.bloom_back x pack; incr (envs.bloom_next) let find_bloom envs pack = try PackTable.find envs.bloom pack with Not_found -> assert false (*********************************************) (* (\* Gather the occurring AC/A symbols *\) *) (*********************************************) (** This modules exhibit a function that memoize in the environment all the AC/A operators as well as the morphism that occur. This staging process allows us to prefer AC/A operators over raw morphisms. Moreover, for each AC/A operators, we need to try to infer units. Otherwise, we do not have [x * y * x <= a * a] since 1 does not occur. But, do we also need to check whether constants are units. Otherwise, we do not have the ability to rewrite [0 = a + a] in [a = ...]*) module Gather : sig val gather : Environ.env -> Evd.evar_map -> Coq.Relation.t -> envs -> constr -> Evd.evar_map end = struct let memoize envs t pack : unit = begin HMap.add envs.discr t (Some pack); add_bloom envs pack; match pack with | Bin (_, None) | Sym _ -> () | Bin (_, Some (unit_of)) -> let unit = unit_of.Unit.uf_u in HMap.add envs.discr unit (Some (Unit unit)); add_bloom envs (Unit unit); | Unit _ -> assert false end let get_unit (rlt : Coq.Relation.t) op env sigma : (Evd.evar_map * constr * constr ) option= let x = (rlt.Coq.Relation.carrier) in let sigma,unit = Evarutil.new_evar env sigma x in let ty =Classes.Unit.ty rlt op unit in let result = try let sigma,t = Typeclasses.resolve_one_typeclass env sigma ty in Some (sigma,t,unit) with Not_found -> None in match result with | None -> None | Some (sigma,s,unit) -> let unit = Evarutil.nf_evar sigma unit in Some (sigma, unit, s) (** gives back the class and the operator *) let is_bin (rlt: Coq.Relation.t) (op: constr) env (sigma : Evd.evar_map) : (Evd.evar_map * Bin.pack) option = let assoc_ty = Classes.Associative.ty rlt op in let comm_ty = Classes.Commutative.ty rlt op in let idem_ty = Classes.Idempotent.ty rlt op in let proper_ty = Classes.Proper.ty rlt op 2 in try let sigma, proper = Typeclasses.resolve_one_typeclass env sigma proper_ty in let sigma, assoc = Typeclasses.resolve_one_typeclass env sigma assoc_ty in let sigma, comm = try let sigma,comm = Typeclasses.resolve_one_typeclass env sigma comm_ty in sigma, Some comm with Not_found -> sigma, None in let sigma, idem = try let sigma,idem = Typeclasses.resolve_one_typeclass env sigma idem_ty in sigma, Some idem with Not_found -> sigma, None in let bin = {Bin.value = EConstr.to_constr sigma op; Bin.compat = EConstr.to_constr sigma proper; Bin.assoc = EConstr.to_constr sigma assoc; Bin.comm = Option.map (EConstr.to_constr sigma) comm; Bin.idem = Option.map (EConstr.to_constr sigma) idem } in Some (sigma,bin) with |Not_found -> None let is_bin (rlt : Coq.Relation.t) (op : constr) env (sigma : Evd.evar_map)= match is_bin rlt op env sigma with | None -> None | Some (sigma, bin_pack) -> match get_unit rlt op env sigma with | None -> Some (sigma, Bin (bin_pack, None)) | Some (gl, unit,s) -> let unit_of = { Unit.uf_u = EConstr.to_constr sigma unit; (* TRICK : this term is not well-typed by itself, but it is okay the way we use it in the other functions *) Unit.uf_idx = EConstr.to_constr sigma op; Unit.uf_desc = EConstr.to_constr sigma s; } in Some (gl,Bin (bin_pack, Some (unit_of))) (** {is_morphism} try to infer the kind of operator we are dealing with *) let is_morphism env sigma (rlt : Coq.Relation.t) (papp : constr) (ar : int) : (Evd.evar_map * pack ) option = let typeof = Classes.Proper.mk_typeof rlt ar in let relof = Classes.Proper.mk_relof rlt ar in let m = Coq.Classes.mk_morphism typeof relof papp in try let sigma,m= Typeclasses.resolve_one_typeclass env sigma m in let pack = {Sym.ar = Coq.Nat.of_int ar; Sym.value= EConstr.to_constr sigma papp; Sym.morph= EConstr.to_constr sigma m} in Some (sigma, Sym pack) with | Not_found -> None (* [crop_app f [| a_0 ; ... ; a_n |]] returns Some (f a_0 ... a_(n-2), [|a_(n-1); a_n |] ) *) let crop_app t ca : (constr * constr array) option= let n = Array.length ca in if n <= 1 then None else let papp = mkApp (t, Array.sub ca 0 (n-2) ) in let args = Array.sub ca (n-2) 2 in Some (papp, args ) let fold env sigma (rlt : Coq.Relation.t) envs t ca cont = let fold_morphism t ca = let nb_params = Array.length ca in let rec aux n = assert (n < nb_params && 0 < nb_params ); let papp = mkApp (t, Array.sub ca 0 n) in match is_morphism env sigma rlt papp (nb_params - n) with | None -> (* here we have to memoize the failures *) HMap.add envs.discr (EConstr.to_constr sigma papp) None; if n < nb_params - 1 then aux (n+1) else sigma | Some (sigma, pack) -> let args = Array.sub ca (n) (nb_params -n)in let sigma = Array.fold_left cont sigma args in memoize envs (EConstr.to_constr sigma papp) pack; sigma in if nb_params = 0 then sigma else aux 0 in let is_aac t = is_bin rlt t in match crop_app t ca with | None -> fold_morphism t ca | Some (papp, args) -> begin match is_aac papp env sigma with | None -> fold_morphism t ca | Some (sigma, pack) -> memoize envs (EConstr.to_constr sigma papp) pack; Array.fold_left cont sigma args end (* update in place the envs of known stuff, using memoization. We have to memoize failures, here. *) let gather env sigma (rlt : Coq.Relation.t ) envs t : Evd.evar_map = let rec aux sigma x = match Coq.decomp_term sigma x with | Constr.App (t,ca) -> fold env sigma rlt envs t ca (aux ) | _ -> sigma in aux sigma t end (** We build a term out of a constr, updating in place the environment if needed (the only kind of such updates are the constants). *) module Parse : sig val t_of_constr : Environ.env -> Evd.evar_map -> Coq.Relation.t -> envs -> constr -> Matcher.Terms.t * Evd.evar_map end = struct (** [discriminates goal envs rlt t ca] infer : - its {! pack } (is it an AC operator, or an A operator, or a Symbol ?), - the relevant partial application, - the vector of the remaining arguments We use an expansion to handle the special case of units, before going back to the general discrimination procedure. That means that a unit is more coarse than a raw morphism This functions is prevented to go through [ar < 0] by the fact that a constant is a morphism. But not an eva. *) let is_morphism env sigma (rlt : Coq.Relation.t) (papp : constr) (ar : int) : (Evd.evar_map * pack ) option = let typeof = Classes.Proper.mk_typeof rlt ar in let relof = Classes.Proper.mk_relof rlt ar in let m = Coq.Classes.mk_morphism typeof relof papp in try let sigma,m = Typeclasses.resolve_one_typeclass env sigma m in let pack = {Sym.ar = Coq.Nat.of_int ar; Sym.value= EConstr.to_constr ~abort_on_undefined_evars:(false) sigma papp; Sym.morph= EConstr.to_constr ~abort_on_undefined_evars:(false) sigma m} in Some (sigma, Sym pack) with | e -> None exception NotReflexive let discriminate env sigma envs (rlt : Coq.Relation.t) t ca : Evd.evar_map * pack * constr * constr array = let nb_params = Array.length ca in let rec fold sigma ar :Evd.evar_map * pack * constr * constr array = begin assert (0 <= ar && ar <= nb_params); let p_app = mkApp (t, Array.sub ca 0 (nb_params - ar)) in begin try begin match HMap.find envs.discr (EConstr.to_constr ~abort_on_undefined_evars:(false) sigma p_app) with | None -> fold sigma (ar-1) | Some pack -> (sigma, pack, p_app, Array.sub ca (nb_params -ar ) ar) end with Not_found -> (* Could not find this constr *) memoize (is_morphism env sigma rlt p_app ar) p_app ar end end and memoize (x) p_app ar = assert (0 <= ar && ar <= nb_params); match x with | Some (sigma, pack) -> HMap.add envs.discr (EConstr.to_constr ~abort_on_undefined_evars:(false) sigma p_app) (Some pack); add_bloom envs pack; (sigma, pack, p_app, Array.sub ca (nb_params-ar) ar) | None -> if ar = 0 then raise NotReflexive; begin (* to memoise the failures *) HMap.add envs.discr (EConstr.to_constr ~abort_on_undefined_evars:(false) sigma p_app) None; (* will terminate, since [const] is capped, and it is easy to find an instance of a constant *) fold sigma (ar-1) end in try match HMap.find envs.discr (EConstr.to_constr ~abort_on_undefined_evars:(false) sigma (mkApp (t,ca))) with | None -> fold sigma (nb_params) | Some pack -> sigma, pack, (mkApp (t,ca)), [| |] with Not_found -> fold sigma (nb_params) let discriminate env sigma envs rlt x = try match Coq.decomp_term sigma x with | Constr.App (t,ca) -> discriminate env sigma envs rlt t ca | _ -> discriminate env sigma envs rlt x [| |] with | NotReflexive -> user_error @@ Pp.strbrk "The relation to which the goal was lifted is not Reflexive" (* TODO: is it the only source of invalid use that fall into this catch_all ? *) | e -> user_error @@ Pp.strbrk "Cannot handle this kind of hypotheses (variables occurring under a function symbol which is not a proper morphism)." (** [t_of_constr env sigma rlt envs cstr] builds the abstract syntax tree of the term [cstr]. Doing so, it modifies the environment of known stuff [envs], and eventually creates fresh evars. Therefore, we give back the evar map updated accordingly *) let t_of_constr env sigma (rlt: Coq.Relation.t ) envs : constr -> Matcher.Terms.t * Evd.evar_map = let r_sigma = ref (sigma) in let rec aux x = match Coq.decomp_term sigma x with | Constr.Rel i -> Matcher.Terms.Var i | _ -> let sigma, pack , p_app, ca = discriminate env (!r_sigma) envs rlt x in r_sigma := sigma; let k = find_bloom envs pack in match pack with | Bin (pack,_) -> begin match pack.Bin.comm with | Some _ -> assert (Array.length ca = 2); Matcher.Terms.Plus ( k, aux ca.(0), aux ca.(1)) | None -> assert (Array.length ca = 2); Matcher.Terms.Dot ( k, aux ca.(0), aux ca.(1)) end | Unit _ -> assert (Array.length ca = 0); Matcher.Terms.Unit ( k) | Sym _ -> Matcher.Terms.Sym ( k, Array.map aux ca) in ( fun x -> let r = aux x in r, !r_sigma ) end (* Parse *) let add_symbol env sigma rlt envs l = let sigma = Gather.gather env sigma rlt envs (EConstr.of_constr (Constr.mkApp (l, [| Constr.mkRel 0;Constr.mkRel 0|]))) in sigma (* [t_of_constr] buils a the abstract syntax tree of a constr, updating in place the environment. Doing so, we infer all the morphisms and the AC/A operators. It is mandatory to do so both for the pattern and the term, since AC symbols can occur in one and not the other *) let t_of_constr env sigma rlt envs (l,r) = let sigma = Gather.gather env sigma rlt envs l in let sigma = Gather.gather env sigma rlt envs r in let l,sigma = Parse.t_of_constr env sigma rlt envs l in let r, sigma = Parse.t_of_constr env sigma rlt envs r in l, r, sigma (* An intermediate representation of the environment, with association lists for AC/A operators, and also the raw [packer] information *) type ir = { packer : (int, pack) Hashtbl.t; (* = bloom_back *) bin : (int * Bin.pack) list ; units : (int * Unit.pack) list; sym : (int * constr) list ; matcher_units : Matcher.ext_units } let ir_to_units ir = ir.matcher_units let ir_of_envs env sigma (rlt : Coq.Relation.t) envs = let add x y l = (x,y)::l in let nil = [] in let sym , (bin : (int * Bin.pack with_unit) list), (units : (int * Constr.t) list) = Hashtbl.fold (fun int pack (sym,bin,units) -> match pack with | Bin s -> sym, add (int) s bin, units | Sym s -> add (int) s sym, bin, units | Unit s -> sym, bin, add int s units ) envs.bloom_back (nil,nil,nil) in let matcher_units = let unit_for , is_ac = List.fold_left (fun ((unit_for,is_ac) as acc) (n,(bp,wu)) -> match wu with | None -> acc | Some (unit_of) -> let unit_n = PackTable.find envs.bloom (Unit unit_of.Unit.uf_u) in ( n, unit_n)::unit_for, (n, bp.Bin.comm <> None )::is_ac ) ([],[]) bin in {Matcher.unit_for = unit_for; Matcher.is_ac = is_ac} in let units : (int * Unit.pack) list = List.fold_left (fun acc (n,u) -> (* first, gather all bins with this unit *) let all_bin = List.fold_left ( fun acc (nop,(bp,wu)) -> match wu with | None -> acc | Some unit_of -> if Constr.equal (unit_of.Unit.uf_u) u then {unit_of with Unit.uf_idx = EConstr.to_constr sigma (Coq.Pos.of_int nop)} :: acc else acc ) [] bin in (n,{ Unit.u_value = EConstr.of_constr u; Unit.u_desc = all_bin })::acc ) [] units in sigma, { packer = envs.bloom_back; bin = (List.map (fun (n,(s,_)) -> n, s) bin); units = units; sym = (List.map (fun (n,s) -> n,(Sym.mk_pack rlt s)) sym); matcher_units = matcher_units } (** {1 From AST back to Coq } The next functions allow one to map OCaml abstract syntax trees to Coq terms *) (** {2 Building raw, natural, terms} *) (** [raw_constr_of_t_debruijn] rebuilds a term in the raw representation, without products on top, and maybe escaping free debruijn indices (in the case of a pattern for example). *) let raw_constr_of_t_debruijn ir (t : Matcher.Terms.t) : constr * int list = let add_set,get = let r = ref [] in let rec add x = function [ ] -> [x] | t::q when t = x -> t::q | t::q -> t:: (add x q) in (fun x -> r := add x !r),(fun () -> !r) in (* Here, we rely on the invariant that the maps are well formed: it is meanigless to fail to find a symbol in the maps, or to find the wrong kind of pack in the maps *) let rec aux t = match t with | Matcher.Terms.Plus (s,l,r) -> begin match Hashtbl.find ir.packer s with | Bin (s,_) -> mkApp (EConstr.of_constr s.Bin.value , [|(aux l);(aux r)|]) | _ -> Printf.printf "erreur:%i\n%!"s; assert false end | Matcher.Terms.Dot (s,l,r) -> begin match Hashtbl.find ir.packer s with | Bin (s,_) -> mkApp (EConstr.of_constr s.Bin.value, [|(aux l);(aux r)|]) | _ -> assert false end | Matcher.Terms.Sym (s,t) -> begin match Hashtbl.find ir.packer s with | Sym s -> mkApp (EConstr.of_constr s.Sym.value, Array.map aux t) | _ -> assert false end | Matcher.Terms.Unit x -> begin match Hashtbl.find ir.packer x with | Unit s -> EConstr.of_constr s | _ -> assert false end | Matcher.Terms.Var i -> add_set i; mkRel (i) in let t = aux t in t , get ( ) (** [raw_constr_of_t] rebuilds a term in the raw representation *) let raw_constr_of_t ir rlt (context:rel_context) t = (* cap rebuilds the products in front of the constr *) let rec cap c = function [] -> c | t::q -> let i = Context.Rel.lookup t context in cap (mkProd_or_LetIn i c) q in let t,indices = raw_constr_of_t_debruijn ir t in cap t (List.sort (Stdlib.compare) indices) (** {2 Building reified terms} *) (* Some informations to be able to build the maps *) type reif_params = { bin_null : Bin.pack; (* the default A operator *) sym_null : constr; unit_null : Unit.pack; sym_ty : constr; (* the type, as it appears in e_sym *) bin_ty : constr } (** A record containing the environments that will be needed by the decision procedure, as a Coq constr. Contains the functions from the symbols (as ints) to indexes (as constr) *) type sigmas = { env_sym : constr; env_bin : constr; env_units : constr; (* the [idx -> X:constr] *) } type sigma_maps = { sym_to_pos : int -> constr; bin_to_pos : int -> constr; units_to_pos : int -> constr; } (** infers some stuff that will be required when we will build environments (our environments need a default case, so we need an Op_AC, an Op_A, and a symbol) *) (* Note : this function can fail if the user is using the wrong relation, like proving a = b, while the classes are defined with another relation (==) *) let build_reif_params env sigma (rlt : Coq.Relation.t) (zero) : Evd.evar_map * reif_params = let carrier = rlt.Coq.Relation.carrier in let sigma,bin_null = try let sigma, op = Coq.evar_binary env sigma carrier in let sigma, assoc = Classes.Associative.infer env sigma rlt op in let sigma, compat = Classes.Proper.infer env sigma rlt op 2 in let op = Evarutil.nf_evar sigma op in sigma,{ Bin.value = EConstr.to_constr sigma op; Bin.compat = EConstr.to_constr sigma compat; Bin.assoc = EConstr.to_constr sigma assoc; Bin.comm = None; Bin.idem = None } with Not_found -> user_error @@ Pp.strbrk "Cannot infer a default A operator (required at least to be Proper and Associative)" in let sigma,zero = try let sigma, evar_op = Coq.evar_binary env sigma carrier in let sigma,evar_unit = Evarutil.new_evar env sigma carrier in let query = Classes.Unit.ty rlt evar_op evar_unit in let sigma, _ = Typeclasses.resolve_one_typeclass env sigma query in sigma,Evarutil.nf_evar sigma evar_unit with _ -> sigma,zero in let sym_null = Sym.null rlt in let unit_null = Unit.default zero in let record = { bin_null = bin_null; sym_null = sym_null; unit_null = unit_null; sym_ty = Sym.mk_ty rlt ; bin_ty = Bin.mk_ty rlt } in sigma,record (* We want to lift down the indexes of symbols. *) let renumber (l: (int * 'a) list ) = let _, l = List.fold_left (fun (next,acc) (glob,x) -> (next+1, (next,glob,x)::acc) ) (1,[]) l in let rec to_global loc = function | [] -> assert false | (local, global,x)::q when local = loc -> global | _::q -> to_global loc q in let rec to_local glob = function | [] -> assert false | (local, global,x)::q when global = glob -> local | _::q -> to_local glob q in let locals = List.map (fun (local,global,x) -> local,x) l in locals, (fun x -> to_local x l) , (fun x -> to_global x l) (** [build_sigma_maps] given a envs and some reif_params, we are able to build the sigmas *) let build_sigma_maps (rlt : Coq.Relation.t) zero ir : (sigmas * sigma_maps) Proofview.tactic = let open Proofview.Notations in let open Proofview in tclEVARMAP >>= fun sigma -> Proofview.Goal.enter_one (fun goal -> let env = Proofview.Goal.env goal in let sigma,rp = build_reif_params env sigma rlt zero in Unsafe.tclEVARS sigma <*> let renumbered_sym, to_local, to_global = renumber ir.sym in let env_sym = Sigma.of_list rp.sym_ty (rp.sym_null) renumbered_sym in Coq.mk_letin "env_sym" env_sym >>= fun env_sym -> let bin = (List.map ( fun (n,s) -> n, Bin.mk_pack rlt s) ir.bin) in let env_bin = Sigma.of_list rp.bin_ty (Bin.mk_pack rlt rp.bin_null) bin in (* let goalE = Proofview.Goal.goal goal in *) Coq.mk_letin "env_bin" env_bin >>= fun env_bin -> let units = (List.map (fun (n,s) -> n, Unit.mk_pack rlt env_bin s)ir.units) in let env_units = Sigma.of_list (Unit.ty_unit_pack rlt env_bin) (Unit.mk_pack rlt env_bin rp.unit_null ) units in Coq.mk_letin "env_units" env_units >>= fun env_units -> let sigmas = { env_sym = env_sym ; env_bin = env_bin ; env_units = env_units; } in let f = List.map (fun (x,_) -> (x,Coq.Pos.of_int x)) in let sigma_maps = { sym_to_pos = (let sym = f renumbered_sym in fun x -> (List.assoc (to_local x) sym)); bin_to_pos = (let bin = f bin in fun x -> (List.assoc x bin)); units_to_pos = (let units = f units in fun x -> (List.assoc x units)); } in tclUNIT (sigmas, sigma_maps)) (** builders for the reification *) type reif_builders = { rsum: constr -> constr -> constr -> constr; rprd: constr -> constr -> constr -> constr; rsym: constr -> constr array -> constr; runit : constr -> constr } (* donne moi une tactique, je rajoute ma part. Potentiellement, il est possible d'utiliser la notation 'do' a la Haskell: http://www.cas.mcmaster.ca/~carette/pa_monad/ *) let mk_vect vnil vcons v = let ar = Array.length v in let rec aux = function | 0 -> vnil | n -> let n = n-1 in mkApp( vcons, [| of_constr (Coq.Nat.of_int n); v.(ar - 1 - n); (aux (n)) |] ) in aux ar (* TODO: use a do notation *) let mk_reif_builders (rlt: Coq.Relation.t) (env_sym:constr) : (reif_builders Proofview.tactic) = let x = (rlt.Coq.Relation.carrier) in let r = (rlt.Coq.Relation.r) in let x_r_env = [|x;r;env_sym|] in let tty = mkApp (Coq.get_efresh Stubs._Tty, x_r_env) in let rsum = mkApp (Coq.get_efresh Stubs.rsum, x_r_env) in let rprd = mkApp (Coq.get_efresh Stubs.rprd, x_r_env) in let rsym = mkApp (Coq.get_efresh Stubs.rsym, x_r_env) in let vnil = mkApp (Coq.get_efresh Stubs.vnil, x_r_env) in let vcons = mkApp (Coq.get_efresh Stubs.vcons, x_r_env) in let open Proofview.Notations in Coq.mk_letin "tty" tty >>= fun tty -> Coq.mk_letin "rsum" rsum >>= fun rsum -> Coq.mk_letin "rprd" rprd >>= fun rprd -> Coq.mk_letin "rsym" rsym >>= fun rsym -> Coq.mk_letin "vnil" vnil >>= fun vnil -> Coq.mk_letin "vcons" vcons >>= fun vcons -> Proofview.tclUNIT { rsum = begin fun idx l r -> mkApp (rsum, [| idx ; mk_mset tty [l,1 ; r,1]|]) end; rprd = begin fun idx l r -> let lst = NEList.of_list tty [l;r] in mkApp (rprd, [| idx; lst|]) end; rsym = begin fun idx v -> let vect = mk_vect vnil vcons v in mkApp (rsym, [| idx; vect|]) end; runit = fun idx -> (* could benefit of a letin *) mkApp (Coq.get_efresh Stubs.runit , [|x;r;env_sym;idx; |]) } type reifier = sigma_maps * reif_builders let mk_reifier rlt zero envs : (sigmas *reifier) Proofview.tactic = let open Proofview.Notations in build_sigma_maps rlt zero envs >>= fun (s,sm) -> mk_reif_builders rlt s.env_sym >>= fun rb -> Proofview.tclUNIT (s,(sm,rb)) (** [reif_constr_of_t reifier t] rebuilds the term [t] in the reified form. We use the [reifier] to minimise the size of the terms (we make as much lets as possible)*) let reif_constr_of_t (sm,rb) (t:Matcher.Terms.t) : constr = let rec aux = function | Matcher.Terms.Plus (s,l,r) -> let idx = sm.bin_to_pos s in rb.rsum idx (aux l) (aux r) | Matcher.Terms.Dot (s,l,r) -> let idx = sm.bin_to_pos s in rb.rprd idx (aux l) (aux r) | Matcher.Terms.Sym (s,t) -> let idx = sm.sym_to_pos s in rb.rsym idx (Array.map aux t) | Matcher.Terms.Unit s -> let idx = sm.units_to_pos s in rb.runit idx | Matcher.Terms.Var i -> anomaly "call to reif_constr_of_t on a term with variables." in aux t end aac-tactics-8.18.0/src/helper.mli0000644000175000017500000000241714463022056016163 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Debugging functions, that can be triggered on a per-file base. *) module type CONTROL = sig val debug : bool val time : bool val printing : bool end module Debug : functor (X : CONTROL) -> sig (** {!debug} prints the string and end it with a newline *) val debug : string -> unit val debug_exception : string -> exn -> unit (** {!time} computes the time spent in a function, and then print it using the given format *) val time : ('a -> 'b) -> 'a -> (float -> unit, out_channel, unit) format -> 'b (** {!pr_constr} print a Coq constructor, that can be labelled by a string *) val pr_constr : Environ.env -> Evd.evar_map -> string -> EConstr.constr -> unit end aac-tactics-8.18.0/src/aac_rewrite.ml0000644000175000017500000003656014463022056017026 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** aac_rewrite -- rewriting modulo A or AC*) open Ltac_plugin module Control = struct let debug = false let printing = false let time = false end module Debug = Helper.Debug (Control) open Debug let time_tac msg tac = if Control.time then Proofview.tclTIME (Some msg) tac else tac let tclTac_or_exn (tac : 'a Proofview.tactic) exn msg : 'a Proofview.tactic = Proofview.tclORELSE tac (fun e -> let open Proofview.Notations in let open Proofview in tclEVARMAP >>= fun sigma -> Goal.enter_one (fun gl -> let env = Proofview.Goal.env gl in pr_constr env sigma "last goal" (Goal.concl gl); exn msg e) ) open EConstr open Names (** aac_lift : the ideal type beyond AAC_rewrite.v/Lift A base relation r, together with an equivalence relation, and the proof that the former lifts to the later. Howver, we have to ensure manually the invariant : r.carrier == e.carrier, and that lift connects the two things *) type aac_lift = { r : Coq.Relation.t; e : Coq.Equivalence.t; lift : constr } type rewinfo = { hypinfo : Coq.Rewrite.hypinfo; in_left : bool; (** are we rewriting in the left hand-sie of the goal *) pattern : constr; subject : constr; morph_rlt : Coq.Relation.t; (** the relation we look for in morphism *) eqt : Coq.Equivalence.t; (** the equivalence we use as workbase *) rlt : Coq.Relation.t; (** the relation in the goal *) lifting: aac_lift } let infer_lifting env sigma (rlt: Coq.Relation.t) : Evd.evar_map * aac_lift = let x = rlt.Coq.Relation.carrier in let r = rlt.Coq.Relation.r in let (sigma, e) = Coq.evar_relation env sigma x in let lift_ty = mkApp (Coq.get_efresh Theory.Stubs.lift,[|x;r;e|]) in let sigma, lift = try Typeclasses.resolve_one_typeclass env sigma lift_ty with Not_found -> CErrors.user_err (Pp.strbrk "Cannot infer a lifting") in let eq = (Evarutil.nf_evar sigma e) in let equiv = mkApp (Coq.get_efresh Theory.Stubs.lift_proj_equivalence,[| x;r;eq; lift |]) in sigma, { r = rlt; e = Coq.Equivalence.make x eq equiv; lift = lift; } (** Builds a rewinfo, once and for all *) let dispatch env sigma in_left (left,right,rlt) hypinfo : Evd.evar_map * rewinfo = let l2r = hypinfo.Coq.Rewrite.l2r in let sigma,lift = infer_lifting env sigma rlt in let eq = lift.e in sigma,{ hypinfo = hypinfo; in_left = in_left; pattern = if l2r then hypinfo.Coq.Rewrite.left else hypinfo.Coq.Rewrite.right; subject = if in_left then left else right; morph_rlt = Coq.Equivalence.to_relation eq; eqt = eq; lifting = lift; rlt = rlt } (** {1 Tactics} *) (** Build the reifiers, the reified terms, and the evaluation fonction *) let handle eqt zero envs (t : Matcher.Terms.t) (t' : Matcher.Terms.t) : ('a * 'b * 'c * 'd) Proofview.tactic= let (x,r,_) = Coq.Equivalence.split eqt in let open Proofview.Notations in Theory.Trans.mk_reifier (Coq.Equivalence.to_relation eqt) zero envs >>= fun (maps, reifier) -> (* fold through a term and reify *) let t = Theory.Trans.reif_constr_of_t reifier t in let t' = Theory.Trans.reif_constr_of_t reifier t' in (* Some letins *) let eval = (mkApp (Coq.get_efresh Theory.Stubs.eval, [|x;r; maps.Theory.Trans.env_sym; maps.Theory.Trans.env_bin; maps.Theory.Trans.env_units|])) in Coq.mk_letin "eval" eval >>= fun eval -> Coq.mk_letin "left" t >>= fun t -> Coq.mk_letin "right" t' >>= fun t' -> Proofview.tclUNIT (maps, eval, t,t') (** [by_aac_reflexivity] is a sub-tactic that closes a sub-goal that is merely a proof of equality of two terms modulo AAC *) let by_aac_reflexivity zero eqt envs (t : Matcher.Terms.t) (t' : Matcher.Terms.t) : unit Proofview.tactic = let open Proofview.Notations in handle eqt zero envs t t' >>= fun (maps,eval,t,t') -> let (x,r,e) = Coq.Equivalence.split eqt in let decision_thm = mkApp (Coq.get_efresh Theory.Stubs.decide_thm, [|x;r;e; maps.Theory.Trans.env_sym; maps.Theory.Trans.env_bin; maps.Theory.Trans.env_units; t;t'; |]) in (* This convert is required to deal with evars in a proper way *) let convert_to = mkApp (r, [| mkApp (eval,[| t |]); mkApp (eval, [|t'|])|]) in let convert = Tactics.convert_concl ~cast:true ~check:true convert_to Constr.VMcast in let apply_tac = Tactics.apply decision_thm in let open Proofview in Coq.tclRETYPE decision_thm <*> Coq.tclRETYPE convert_to <*> convert <*> tclTac_or_exn apply_tac Coq.user_error (Pp.strbrk "unification failure") <*> tclTac_or_exn (time_tac "vm_norm" Tactics.normalise_in_concl) Coq.anomaly "vm_compute failure" <*> tclORELSE Tactics.reflexivity (fun _ -> Tacticals.tclFAIL (Pp.str "Not an equality modulo A/AC")) let by_aac_normalise zero lift ir t t' = let eqt = lift.e in let rlt = lift.r in let open Proofview.Notations in handle eqt zero ir t t' >>= fun (maps,eval,t,t') -> let (x,r,e) = Coq.Equivalence.split eqt in let normalise_thm = mkApp (Coq.get_efresh Theory.Stubs.lift_normalise_thm, [|x;r;e; maps.Theory.Trans.env_sym; maps.Theory.Trans.env_bin; maps.Theory.Trans.env_units; rlt.Coq.Relation.r; lift.lift; t;t'; |]) in (* This convert is required to deal with evars in a proper way *) let convert_to = mkApp (rlt.Coq.Relation.r, [| mkApp (eval,[| t |]); mkApp (eval, [|t'|])|]) in let convert = Tactics.convert_concl ~cast:true ~check:true convert_to Constr.VMcast in let apply_tac = Tactics.apply normalise_thm in Tacticals.tclTHENLIST [ Coq.tclRETYPE normalise_thm; Coq.tclRETYPE convert_to; convert ; apply_tac; ] (** A handler function, that reifies the goal, and infers the lifting *) let aac_conclude env sigma (concl:types): ( Evd.evar_map * constr * aac_lift * Theory.Trans.ir * Matcher.Terms.t * Matcher.Terms.t) = let envs = Theory.Trans.empty_envs () in let left, right,r = match Coq.match_as_equation env sigma concl with | None -> Coq.user_error @@ Pp.strbrk "The goal is not an applied relation" | Some x -> x in try let sigma,lift = infer_lifting env sigma r in let eq = Coq.Equivalence.to_relation lift.e in let tleft,tright, sigma = Theory.Trans.t_of_constr env sigma eq envs (left,right) in let sigma, ir = Theory.Trans.ir_of_envs env sigma eq envs in let _ = pr_constr env sigma "concl" concl in (sigma,left,lift,ir,tleft,tright) with | Not_found -> Coq.user_error @@ Pp.strbrk "No lifting from the goal's relation to an equivalence" open Tacexpr let aac_normalise = let mp = MPfile (DirPath.make (List.map Id.of_string ["AAC"; "AAC_tactics"])) in let norm_tac = KerName.make mp (Label.make "internal_normalize") in let norm_tac = Locus.ArgArg (None, norm_tac) in let open Proofview.Notations in let open Proofview in Proofview.Goal.enter (fun goal -> let ids = Tacmach.pf_ids_of_hyps goal in let env = Proofview.Goal.env goal in tclEVARMAP >>= fun sigma -> let concl = Proofview.Goal.concl goal in let sigma,left,lift,ir,tleft,tright = aac_conclude env sigma concl in Tacticals.tclTHENLIST [ Unsafe.tclEVARS sigma; by_aac_normalise left lift ir tleft tright; Tacinterp.eval_tactic (CAst.(make @@ TacArg (TacCall (make (norm_tac, []))))); Tactics.keep ids ]) let aac_reflexivity : unit Proofview.tactic = let open Proofview.Notations in let open Proofview in tclEVARMAP >>= fun sigma -> Goal.enter (fun goal -> let env = Proofview.Goal.env goal in let concl = Goal.concl goal in let sigma,zero,lift,ir,t,t' = aac_conclude env sigma concl in let x,r = Coq.Relation.split (lift.r) in let r_reflexive = (Coq.Classes.mk_reflexive x r) in let sigma,reflexive = try Typeclasses.resolve_one_typeclass env sigma r_reflexive with | Not_found -> Coq.user_error @@ Pp.strbrk "The goal's relation is not reflexive" in let lift_reflexivity = mkApp (Coq.get_efresh (Theory.Stubs.lift_reflexivity), [| x; r; lift.e.Coq.Equivalence.eq; lift.lift; reflexive |]) in Unsafe.tclEVARS sigma <*> Coq.tclRETYPE lift_reflexivity <*> Tactics.apply lift_reflexivity <*> (let concl = Goal.concl goal in tclEVARMAP >>= fun sigma -> let _ = pr_constr env sigma "concl "concl in by_aac_reflexivity zero lift.e ir t t') ) (** A sub-tactic to lift the rewriting using Lift *) let lift_transitivity in_left (step:constr) preorder lifting (using_eq : Coq.Equivalence.t): unit Proofview.tactic = let open Proofview.Notations in let open Proofview in Proofview.Goal.enter (fun goal -> (* catch the equation and the two members*) let concl = Proofview.Goal.concl goal in let env = Proofview.Goal.env goal in tclEVARMAP >>= fun sigma -> let (left, right, _ ) = match Coq.match_as_equation env sigma concl with | Some x -> x | None -> Coq.user_error @@ Pp.strbrk "The goal is not an equation" in let lift_transitivity = let thm = if in_left then Theory.Stubs.lift_transitivity_left else Theory.Stubs.lift_transitivity_right in mkApp (Coq.get_efresh thm, [| preorder.Coq.Relation.carrier; preorder.Coq.Relation.r; using_eq.Coq.Equivalence.eq; lifting; step; left; right; |]) in Tacticals.tclTHENLIST [ Coq.tclRETYPE lift_transitivity; Tactics.apply lift_transitivity ] ) (** The core tactic for aac_rewrite. *) let core_aac_rewrite ?abort rewinfo subst (by_aac_reflexivity : Matcher.Terms.t -> Matcher.Terms.t -> unit Proofview.tactic) (tr : constr) t left : unit Proofview.tactic = let open Proofview.Notations in Proofview.Goal.enter (fun goal -> let env = Proofview.Goal.env goal in Proofview.tclEVARMAP >>= fun sigma -> pr_constr env sigma "transitivity through" tr; let tran_tac = lift_transitivity rewinfo.in_left tr rewinfo.rlt rewinfo.lifting.lift rewinfo.eqt in let rew = Coq.Rewrite.rewrite ?abort rewinfo.hypinfo subst in Tacticals.tclTHENS (tclTac_or_exn (tran_tac) Coq.anomaly "Unable to make the transitivity step") ( if rewinfo.in_left then [ by_aac_reflexivity left t ; rew ] else [ by_aac_reflexivity t left ; rew ] ) ) exception NoSolutions (** Choose a substitution from a [(int * Terms.t * Env.env Search_monad.m) Search_monad.m ] *) (* WARNING: Beware, since the printing function can change the order of the printed monad, this function has to be updated accordingly *) let choose_subst subterm sol m= try let (depth,pat,envm) = match subterm with | None -> (* first solution *) List.nth ( List.rev (Search_monad.to_list m)) 0 | Some x -> List.nth ( List.rev (Search_monad.to_list m)) x in let env = match sol with None -> List.nth ( (Search_monad.to_list envm)) 0 | Some x -> List.nth ( (Search_monad.to_list envm)) x in pat, env with | _ -> raise NoSolutions (** rewrite the constr modulo AC from left to right in the left member of the goal *) let aac_rewrite_wrap ?abort ?(l2r=true) ?(show = false) ?(in_left=true) ?strict ?extra ~occ_subterm ~occ_sol rew : unit Proofview.tactic = let open Proofview.Notations in let open Proofview in Proofview.Goal.enter (fun goal -> let envs = Theory.Trans.empty_envs () in let (concl : types) = Proofview.Goal.concl goal in let env = Proofview.Goal.env goal in tclEVARMAP >>= fun sigma -> let (_,_,rlt) as concl = match Coq.match_as_equation env sigma concl with | None -> Coq.user_error @@ Pp.strbrk "The goal is not an applied relation" | Some (left, right, rlt) -> left,right,rlt in let check_type x = Tacmach.pf_conv_x goal x rlt.Coq.Relation.carrier in let hypinfo = Coq.Rewrite.get_hypinfo env sigma ?check_type:(Some check_type) rew ~l2r in let sigma,rewinfo = dispatch env sigma in_left concl hypinfo in let sigma = match extra with | Some t -> Theory.Trans.add_symbol env sigma rewinfo.morph_rlt envs (EConstr.to_constr sigma t) | None -> sigma in let pattern, subject, sigma = Theory.Trans.t_of_constr env sigma rewinfo.morph_rlt envs (rewinfo.pattern , rewinfo.subject) in let sigma, ir = Theory.Trans.ir_of_envs env sigma rewinfo.morph_rlt envs in let open Proofview.Notations in Proofview.Unsafe.tclEVARS sigma <*> let units = Theory.Trans.ir_to_units ir in let m = Matcher.subterm ?strict units pattern subject in (* We sort the monad in increasing size of contet *) let m = Search_monad.sort (fun (x,_,_) (y,_,_) -> x - y) m in (if show then Print.print rewinfo.morph_rlt ir m (hypinfo.Coq.Rewrite.context) else try let pat,subst = choose_subst occ_subterm occ_sol m in let tr_step = Matcher.Subst.instantiate subst pat in let tr_step_raw = Theory.Trans.raw_constr_of_t ir rewinfo.morph_rlt [] tr_step in let conv = (Theory.Trans.raw_constr_of_t ir rewinfo.morph_rlt (hypinfo.Coq.Rewrite.context)) in let subst = Matcher.Subst.to_list subst in let subst = List.map (fun (x,y) -> x, conv y) subst in let by_aac_reflexivity = (by_aac_reflexivity rewinfo.subject rewinfo.eqt ir) in (* I'm not sure whether this is the right env/sigma for printing tr_step_raw *) core_aac_rewrite ?abort rewinfo subst by_aac_reflexivity tr_step_raw tr_step subject with | NoSolutions -> Tacticals.tclFAIL (Pp.str (if occ_subterm = None && occ_sol = None then "No matching occurrence modulo AC found" else "No such solution")) )) let get k l = try Some (List.assoc k l) with Not_found -> None let get_lhs l = try ignore (List.assoc "in_right" l); false with Not_found -> true let aac_rewrite ~args = aac_rewrite_wrap ~occ_subterm:(get "at" args) ~occ_sol:(get "subst" args) ~in_left:(get_lhs args) let rec add k x = function | [] -> [k,x] | k',_ as ky::q -> if k'=k then Coq.user_error @@ Pp.strbrk ("redondant argument ("^k^")") else ky::add k x q let pr_aac_args _ _ _ l = List.fold_left (fun acc -> function | ("in_right" as s,_) -> Pp.(++) (Pp.str s) acc | (k,i) -> Pp.(++) (Pp.(++) (Pp.str k) (Pp.int i)) acc ) (Pp.str "") l aac-tactics-8.18.0/src/matcher.mli0000644000175000017500000001627114463022056016332 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Standalone module containing the algorithm for matching modulo associativity and associativity and commutativity (AAC). Additionnaly, some A or AC operators can have units (U). This module could be reused outside of the Coq plugin. Matching a pattern [p] against a term [t] modulo AACU boils down to finding a substitution [env] such that the pattern [p] instantiated with [env] is equal to [t] modulo AACU. We proceed by structural decomposition of the pattern, trying all possible non-deterministic splittings of the subject, when needed. The function {!matcher} is limited to top-level matching, that is, the subject must make a perfect match against the pattern ([x+x] does not match [a+a+b] ). We use a search monad {!Search_monad} to perform non-deterministic choices in an almost transparent way. We also provide a function {!subterm} for finding a match that is a subterm of the subject modulo AACU. In particular, this function gives a solution to the aforementioned case ([x+x] against [a+b+a]). On a slightly more involved level : - it must be noted that we allow several AC/A operators to share the same units, but that a given AC/A operator can have at most one unit. - if the pattern does not contain "hard" symbols (like constants, function symbols, AC or A symbols without units), there can be infinitely many subterms such that the pattern matches: it is possible to build "subterms" modulo AAC and U that make the size of the term increase (by making neutral elements appear in a layered fashion). Hence, in this case, a warning is issued, and some solutions are omitted. *) (** {2 Utility functions} *) type symbol = int type var = int (** Relationship between units and operators. This is a sparse representation of a matrix of couples [(op,unit)] where [op] is the index of the operation, and [unit] the index of the relevant unit. We make the assumption that any operation has 0 or 1 unit, and that operations can share a unit). *) type units =(symbol * symbol) list (* from AC/A symbols to the unit *) type ext_units = { unit_for : units; (* from AC/A symbols to the unit *) is_ac : (symbol * bool) list } (** The arguments of sums (or AC operators) are represented using finite multisets. (Typically, [a+b+a] corresponds to [2.a+b], i.e. [Sum[a,2;b,1]]) *) type 'a mset = ('a * int) list (** [linear] expands a multiset into a simple list *) val linear : 'a mset -> 'a list (** Representations of expressions The module {!Terms} defines two different types for expressions. - a public type {!Terms.t} that represents abstract syntax trees of expressions with binary associative and commutative operators - a private type {!Terms.nf_term}, corresponding to a canonical representation for the above terms modulo AACU. The construction functions on this type ensure that these terms are in normal form (that is, no sum can appear as a subterm of the same sum, no trailing units, lists corresponding to multisets are sorted, etc...). *) module Terms : sig (** {2 Abstract syntax tree of terms and patterns} We represent both terms and patterns using the following datatype. Values of type [symbol] are used to index symbols. Typically, given two associative operations [(^)] and [( * )], and two morphisms [f] and [g], the term [f (a^b) (a*g b)] is represented by the following value [Sym(0,[| Dot(1, Sym(2,[||]), Sym(3,[||])); Dot(4, Sym(2,[||]), Sym(5,[|Sym(3,[||])|])) |])] where the implicit symbol environment associates [f] to [0], [(^)] to [1], [a] to [2], [b] to [3], [( * )] to [4], and [g] to [5], Accordingly, the following value, that contains "variables" [Sym(0,[| Dot(1, Var x, Unit (1); Dot(4, Var x, Sym(5,[|Sym(3,[||])|])) |])] represents the pattern [forall x, f (x^1) (x*g b)]. The relationship between [1] and [( * )] is only mentionned in the units table. *) type t = Dot of (symbol * t * t) | Plus of (symbol * t * t) | Sym of (symbol * t array) | Var of var | Unit of symbol (** Test for equality of terms modulo AACU (relies on the following canonical representation of terms). Note than two different units of a same operator are not considered equal. *) val equal_aac : units -> t -> t -> bool (** {2 Normalised terms (canonical representation) } A term in normal form is the canonical representative of the equivalence class of all the terms that are equal modulo AACU. This representation is only used internally; it is exported here for the sake of completeness *) type nf_term (** {3 Comparisons} *) val nf_term_compare : nf_term -> nf_term -> int val nf_equal : nf_term -> nf_term -> bool (** {3 Printing function} *) val sprint_nf_term : nf_term -> string (** {3 Conversion functions} *) (** we have the following property: [a] and [b] are equal modulo AACU iif [nf_equal (term_of_t a) (term_of_t b) = true] *) val term_of_t : units -> t -> nf_term val t_of_term : nf_term -> t end (** Substitutions (or environments) The module {!Subst} contains infrastructure to deal with substitutions, i.e., functions from variables to terms. Only a restricted subsets of these functions need to be exported. As expected, a particular substitution can be used to instantiate a pattern. *) module Subst : sig type t val sprint : t -> string val instantiate : t -> Terms.t-> Terms.t val to_list : t -> (var*Terms.t) list end (** {2 Main functions exported by this module} *) (** [matcher p t] computes the set of solutions to the given top-level matching problem ([p] is the pattern, [t] is the term). If the [strict] flag is set, solutions where units are used to instantiate some variables are excluded, unless this unit appears directly under a function symbol (e.g., f(x) still matches f(1), while x+x+y does not match a+b+c, since this would require to assign 1 to x). *) val matcher : ?strict:bool -> ext_units -> Terms.t -> Terms.t -> Subst.t Search_monad.m (** [subterm p t] computes a set of solutions to the given subterm-matching problem. Return a collection of possible solutions (each with the associated depth, the context, and the solutions of the matching problem). The context is actually a {!Terms.t} where the variables are yet to be instantiated by one of the associated substitutions *) val subterm : ?strict:bool -> ext_units -> Terms.t -> Terms.t -> (int * Terms.t * Subst.t Search_monad.m) Search_monad.m aac-tactics-8.18.0/src/aac.mlg0000644000175000017500000000461514463022056015430 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** aac -- Reasoning modulo associativity and commutativity *) DECLARE PLUGIN "coq-aac-tactics.plugin" { open Ltac_plugin open Pcoq.Prim open Pcoq.Constr open Stdarg open Aac_rewrite open Extraargs } ARGUMENT EXTEND aac_args TYPED AS (string * int) list PRINTED BY { pr_aac_args } | [ "at" integer(n) aac_args(q) ] -> { add "at" n q } | [ "subst" integer(n) aac_args(q) ] -> { add "subst" n q } | [ "in_right" aac_args(q) ] -> { add "in_right" 0 q } | [ ] -> { [] } END { let pr_constro _ _ _ = fun b -> match b with | None -> Pp.str "" | Some o -> Pp.str "" } ARGUMENT EXTEND constro TYPED AS constr option PRINTED BY { pr_constro } | [ "[" constr(c) "]" ] -> { Some c } | [ ] -> { None } END TACTIC EXTEND _aac_reflexivity_ | [ "aac_reflexivity" ] -> { aac_reflexivity } END TACTIC EXTEND _aac_normalise_ | [ "aac_normalise" ] -> { aac_normalise } END TACTIC EXTEND _aac_rewrite_ | [ "aac_rewrite" orient(l2r) constr(c) aac_args(args) constro(extra)] -> { aac_rewrite ?extra ~args ~l2r ~strict:true c } END TACTIC EXTEND _aac_pattern_ | [ "aac_pattern" orient(l2r) constr(c) aac_args(args) constro(extra)] -> { aac_rewrite ?extra ~args ~l2r ~strict:true ~abort:true c } END TACTIC EXTEND _aac_instances_ | [ "aac_instances" orient(l2r) constr(c) aac_args(args) constro(extra)] -> { aac_rewrite ?extra ~args ~l2r ~strict:true ~show:true c } END TACTIC EXTEND _aacu_rewrite_ | [ "aacu_rewrite" orient(l2r) constr(c) aac_args(args) constro(extra)] -> { aac_rewrite ?extra ~args ~l2r ~strict:false c } END TACTIC EXTEND _aacu_pattern_ | [ "aacu_pattern" orient(l2r) constr(c) aac_args(args) constro(extra)] -> { aac_rewrite ?extra ~args ~l2r ~strict:false ~abort:true c } END TACTIC EXTEND _aacu_instances_ | [ "aacu_instances" orient(l2r) constr(c) aac_args(args) constro(extra)] -> { aac_rewrite ?extra ~args ~l2r ~strict:false ~show:true c } END aac-tactics-8.18.0/src/print.mli0000644000175000017500000000206614463022056016040 0ustar jpuydtjpuydt(***************************************************************************) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (***************************************************************************) (** Pretty printing functions we use for the aac_instances tactic. *) (** The main printing function. {!print} uses the rel-context to rename the variables, and rebuilds raw Coq terms (for the given context, and the terms in the environment). In order to do so, it requires the information gathered by the {!Theory.Trans} module.*) val print : Coq.Relation.t -> Theory.Trans.ir -> (int * Matcher.Terms.t * Matcher.Subst.t Search_monad.m) Search_monad.m -> EConstr.rel_context -> unit Proofview.tactic aac-tactics-8.18.0/Makefile.coq.local0000644000175000017500000000137714463022056016730 0ustar jpuydtjpuydtGLOBFILES = $(VFILES:.v=.glob) CSSFILES = resources/coqdoc.css resources/coqdocjs.css JSFILES = resources/config.js resources/coqdocjs.js HTMLFILES = resources/header.html resources/footer.html COQDOCDIR = docs/coqdoc COQDOCHTMLFLAGS = --toc --toc-depth 3 --index indexpage --html -s \ --interpolate --no-lib-name --parse-comments \ --with-header resources/header.html --with-footer resources/footer.html coqdoc: $(GLOBFILES) $(VFILES) $(CSSFILES) $(JSFILES) $(HTMLFILES) $(SHOW)'COQDOC -d $(COQDOCDIR)' $(HIDE)mkdir -p $(COQDOCDIR) $(HIDE)$(COQDOC) $(COQDOCHTMLFLAGS) $(COQDOCLIBS) -d $(COQDOCDIR) $(VFILES) $(SHOW)'COPY resources' $(HIDE)cp $(CSSFILES) $(JSFILES) $(COQDOCDIR) .PHONY: coqdoc resources/index.html: resources/index.md pandoc -s -o $@ $< aac-tactics-8.18.0/resources/0000755000175000017500000000000014463022056015420 5ustar jpuydtjpuydtaac-tactics-8.18.0/resources/coqdocjs.js0000644000175000017500000001364014463022056017567 0ustar jpuydtjpuydtvar coqdocjs = coqdocjs || {}; (function(){ function replace(s){ var m; if (m = s.match(/^(.+)'/)) { return replace(m[1])+"'"; } else if (m = s.match(/^([A-Za-z]+)_?(\d+)$/)) { return replace(m[1])+m[2].replace(/\d/g, function(d){ if (coqdocjs.subscr.hasOwnProperty(d)) { return coqdocjs.subscr[d]; } else { return d; } }); } else if (coqdocjs.repl.hasOwnProperty(s)){ return coqdocjs.repl[s] } else { return s; } } function toArray(nl){ return Array.prototype.slice.call(nl); } function replInTextNodes() { // Get all the nodes up front. var nodes = Array.from(document.querySelectorAll(".code, .inlinecode")) .flatMap(elem => Array.from(elem.childNodes) .filter(e => e.nodeType == Node.TEXT_NODE) ); // Create a replacement template node to clone from. var replacementTemplate = document.createElement("span"); replacementTemplate.setAttribute("class", "id"); replacementTemplate.setAttribute("type", "keyword"); // Do the replacements. coqdocjs.replInText.forEach(function(toReplace){ var replacement = replacementTemplate.cloneNode(true); replacement.appendChild(document.createTextNode(toReplace)); nodes.forEach(node => { var fragments = node.textContent.split(toReplace); node.textContent = fragments[fragments.length-1]; for (var k = 0; k < fragments.length - 1; ++k) { fragments[k] && node.parentNode.insertBefore(document.createTextNode(fragments[k]),node); node.parentNode.insertBefore(replacement.cloneNode(true), node); } }); }); } function replNodes() { toArray(document.getElementsByClassName("id")).forEach(function(node){ if (["var", "variable", "keyword", "notation", "definition", "inductive"].indexOf(node.getAttribute("type"))>=0){ var text = node.textContent; var replText = replace(text); if(text != replText) { node.setAttribute("repl", replText); node.setAttribute("title", text); var hidden = document.createElement("span"); hidden.setAttribute("class", "hidden"); while (node.firstChild) { hidden.appendChild(node.firstChild); } node.appendChild(hidden); } } }); } function isVernacStart(l, t){ t = t.trim(); for(var s of l){ if (t == s || t.startsWith(s+" ") || t.startsWith(s+".")){ return true; } } return false; } function isProofStart(n){ return isVernacStart(["Proof"], n.textContent) || (isVernacStart(["Next"], n.textContent) && isVernacStart(["Obligation"], n.nextSibling.nextSibling.textContent)); } function isProofEnd(s){ return isVernacStart(["Qed", "Admitted", "Defined", "Abort"], s); } function proofStatus(){ var proofs = toArray(document.getElementsByClassName("proof")); if(proofs.length) { for(var proof of proofs) { if (proof.getAttribute("show") === "false") { return "some-hidden"; } } return "all-shown"; } else { return "no-proofs"; } } function updateView(){ document.getElementById("toggle-proofs").setAttribute("proof-status", proofStatus()); } function foldProofs() { var hasCommands = true; var nodes = document.getElementsByClassName("command"); if(nodes.length == 0) { hasCommands = false; console.log("no command tags found") nodes = document.getElementsByClassName("id"); } toArray(nodes).forEach(function(node){ if(isProofStart(node)) { var proof = document.createElement("span"); proof.setAttribute("class", "proof"); node.parentNode.insertBefore(proof, node); if(proof.previousSibling.nodeType === Node.TEXT_NODE) proof.appendChild(proof.previousSibling); while(node && !isProofEnd(node.textContent)) { proof.appendChild(node); node = proof.nextSibling; } if (proof.nextSibling) proof.appendChild(proof.nextSibling); // the Qed if (!hasCommands && proof.nextSibling) proof.appendChild(proof.nextSibling); // the dot after the Qed proof.addEventListener("click", function(proof){return function(e){ if (e.target.parentNode.tagName.toLowerCase() === "a") return; proof.setAttribute("show", proof.getAttribute("show") === "true" ? "false" : "true"); proof.setAttribute("animate", ""); updateView(); };}(proof)); proof.setAttribute("show", "false"); } }); } function toggleProofs(){ var someProofsHidden = proofStatus() === "some-hidden"; toArray(document.getElementsByClassName("proof")).forEach(function(proof){ proof.setAttribute("show", someProofsHidden); proof.setAttribute("animate", ""); }); updateView(); } function repairDom(){ // pull whitespace out of command toArray(document.getElementsByClassName("command")).forEach(function(node){ while(node.firstChild && node.firstChild.textContent.trim() == ""){ console.log("try move"); node.parentNode.insertBefore(node.firstChild, node); } }); toArray(document.getElementsByClassName("id")).forEach(function(node){ node.setAttribute("type", node.getAttribute("title")); }); toArray(document.getElementsByClassName("idref")).forEach(function(ref){ toArray(ref.childNodes).forEach(function(child){ if (["var", "variable"].indexOf(child.getAttribute("type")) > -1) ref.removeAttribute("href"); }); }); } function fixTitle(){ var url = "/" + window.location.pathname; var basename = url.substring(url.lastIndexOf('/')+1, url.lastIndexOf('.')); if (basename === "toc") {document.title = "Table of Contents";} else if (basename === "indexpage") {document.title = "Index";} else {document.title = basename;} } function postprocess(){ repairDom(); replInTextNodes() replNodes(); foldProofs(); document.getElementById("toggle-proofs").addEventListener("click", toggleProofs); updateView(); } fixTitle(); document.addEventListener('DOMContentLoaded', postprocess); coqdocjs.toggleProofs = toggleProofs; })(); aac-tactics-8.18.0/resources/index.html0000644000175000017500000000637314463022056017426 0ustar jpuydtjpuydt AAC Tactics

AAC Tactics

View the project on GitHub

About

Welcome to the AAC Tactics project website! This project is part of coq-community.

This Coq plugin provides tactics for rewriting and proving universally quantified equations modulo associativity and commutativity of some operator, with idempotent commutative operators enabling additional simplifications. The tactics can be applied for custom operators by registering the operators and their properties as type class instances. Instances for many commonly used operators, such as for binary integer arithmetic and booleans, are provided with the plugin.

This is an open source project, licensed under the GNU Lesser General Public License v3.0 or later.

Get the code

The current stable release of AAC Tactics can be downloaded from GitHub.

Documentation

Help and contact

Authors

  • Thomas Braibant
  • Damien Pous
  • Fabian Kunze
aac-tactics-8.18.0/resources/coqdocjs.css0000644000175000017500000000647014463022056017746 0ustar jpuydtjpuydt/* replace unicode */ .id[repl] .hidden { font-size: 0; } .id[repl]:before{ content: attr(repl); } /* folding proofs */ @keyframes show-proof { 0% { max-height: 1.2em; opacity: 1; } 99% { max-height: 1000em; } 100%{ } } @keyframes hide-proof { from { visibility: visible; max-height: 10em; opacity: 1; } to { max-height: 1.2em; } } .proof { cursor: pointer; } .proof * { cursor: pointer; } .proof { overflow: hidden; position: relative; transition: opacity 1s; display: inline-block; } .proof[show="false"] { max-height: 1.2em; visibility: visible; opacity: 0.3; } .proof[show="false"][animate] { animation-name: hide-proof; animation-duration: 0.25s; } .proof[show="true"] { animation-name: show-proof; animation-duration: 10s; } .proof[show="true"]:before { content: "\25BC"; /* arrow down */ } .proof[show="false"]:before { content: "\25B6"; /* arrow right */ } .proof[show="false"]:hover { visibility: visible; opacity: 0.5; } #toggle-proofs[proof-status="no-proofs"] { display: none; } #toggle-proofs[proof-status="some-hidden"]:before { content: "Show Proofs"; } #toggle-proofs[proof-status="all-shown"]:before { content: "Hide Proofs"; } /* page layout */ html, body { height: 100%; margin:0; padding:0; } @media only screen { /* no div with internal scrolling to allow printing of whole content */ body { display: flex; flex-direction: column } #content { flex: 1; overflow: auto; display: flex; flex-direction: column; } } #content:focus { outline: none; /* prevent glow in OS X */ } #main { display: block; padding: 16px; padding-top: 1em; padding-bottom: 2em; margin-left: auto; margin-right: auto; max-width: 60em; flex: 1 0 auto; } .libtitle { display: none; } /* header */ #header { width:100%; padding: 0; margin: 0; display: flex; align-items: center; background-color: rgb(21,57,105); color: white; font-weight: bold; overflow: hidden; } .button { cursor: pointer; } #header * { text-decoration: none; vertical-align: middle; margin-left: 15px; margin-right: 15px; } #header > .right, #header > .left { display: flex; flex: 1; align-items: center; } #header > .left { text-align: left; } #header > .right { flex-direction: row-reverse; } #header a, #header .button { color: white; box-sizing: border-box; } #header a { border-radius: 0; padding: 0.2em; } #header .button { background-color: rgb(63, 103, 156); border-radius: 1em; padding-left: 0.5em; padding-right: 0.5em; margin: 0.2em; } #header a:hover, #header .button:hover { background-color: rgb(181, 213, 255); color: black; } #header h1 { padding: 0; margin: 0;} /* footer */ #footer { text-align: center; opacity: 0.5; font-size: 75%; } /* hyperlinks */ @keyframes highlight { 50%{ background-color: black; } } :target * { animation-name: highlight; animation-duration: 1s; } a[name]:empty { float: right; } /* Proviola */ div.code { width: auto; float: none; } div.goal { position: fixed; left: 75%; width: 25%; top: 3em; } div.doc { clear: both; } span.command:hover { background-color: inherit; } aac-tactics-8.18.0/resources/index.md0000644000175000017500000000447014463022056017056 0ustar jpuydtjpuydt--- title: AAC Tactics lang: en header-includes: - | ---
View the project on GitHub
## About Welcome to the AAC Tactics project website! This project is part of [coq-community](https://github.com/coq-community/manifesto). This Coq plugin provides tactics for rewriting and proving universally quantified equations modulo associativity and commutativity of some operator, with idempotent commutative operators enabling additional simplifications. The tactics can be applied for custom operators by registering the operators and their properties as type class instances. Instances for many commonly used operators, such as for binary integer arithmetic and booleans, are provided with the plugin. This is an open source project, licensed under the GNU Lesser General Public License v3.0 or later. ## Get the code The current stable release of AAC Tactics can be [downloaded from GitHub](https://github.com/coq-community/aac-tactics/releases). ## Documentation - [paper on initial AAC Tactics version](https://arxiv.org/abs/1106.4448) - [latest coqdoc documentation](https://coq-community.org/aac-tactics/docs/coqdoc/toc.html) - [latest ocamldoc documentation](https://coq-community.org/aac-tactics/docs/ocamldoc/index.html) ## Help and contact - Report issues on [GitHub](https://github.com/coq-community/aac-tactics/issues) - Chat with us on [Zulip](https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users) - Discuss with us on Coq's [Discourse](https://coq.discourse.group) forum ## Authors - Thomas Braibant - Damien Pous - Fabian Kunze aac-tactics-8.18.0/resources/coqdoc.css0000644000175000017500000000613414463022056017406 0ustar jpuydtjpuydt@import url(https://fonts.googleapis.com/css?family=Open+Sans:400,700); body{ font-family: 'Open Sans', sans-serif; font-size: 14px; color: #2D2D2D } a { text-decoration: none; border-radius: 3px; padding-left: 3px; padding-right: 3px; margin-left: -3px; margin-right: -3px; color: inherit; font-weight: bold; } #main .code a, #main .inlinecode a, #toc a { font-weight: inherit; } a[href]:hover, [clickable]:hover{ background-color: rgba(0,0,0,0.1); cursor: pointer; } h, h1, h2, h3, h4, h5 { line-height: 1; color: black; text-rendering: optimizeLegibility; font-weight: normal; letter-spacing: 0.1em; text-align: left; } div + br { display: none; } div:empty{ display: none;} #main h1 { font-size: 2em; } #main h2 { font-size: 1.667rem; } #main h3 { font-size: 1.333em; } #main h4, #main h5, #main h6 { font-size: 1em; } #toc h2 { padding-bottom: 0; } #main .doc { margin: 0; text-align: justify; } .inlinecode, .code, #main pre { font-family: monospace; } .code > br:first-child { display: none; } .doc + .code{ margin-top:0.5em; } .block{ display: block; margin-top: 5px; margin-bottom: 5px; padding: 10px; text-align: center; } .block img{ margin: 15px; } table.infrule { border: 0px; margin-left: 50px; margin-top: 10px; margin-bottom: 10px; } td.infrule { font-family: "Droid Sans Mono", "DejaVu Sans Mono", monospace; text-align: center; padding: 0; line-height: 1; } tr.infrulemiddle hr { margin: 1px 0 1px 0; } .infrulenamecol { color: rgb(60%,60%,60%); padding-left: 1em; padding-bottom: 0.1em } .id[type="constructor"], .id[type="projection"], .id[type="method"], .id[title="constructor"], .id[title="projection"], .id[title="method"] { color: #A30E16; } .id[type="var"], .id[type="variable"], .id[title="var"], .id[title="variable"] { color: inherit; } .id[type="definition"], .id[type="record"], .id[type="class"], .id[type="instance"], .id[type="inductive"], .id[type="library"], .id[title="definition"], .id[title="record"], .id[title="class"], .id[title="instance"], .id[title="inductive"], .id[title="library"] { color: #A6650F; } .id[type="lemma"], .id[title="lemma"]{ color: #188B0C; } .id[type="keyword"], .id[type="notation"], .id[type="abbreviation"], .id[title="keyword"], .id[title="notation"], .id[title="abbreviation"]{ color : #2874AE; } .comment { color: #808080; } /* TOC */ #toc h2{ letter-spacing: 0; font-size: 1.333em; } /* Index */ #index { margin: 0; padding: 0; width: 100%; } #index #frontispiece { margin: 1em auto; padding: 1em; width: 60%; } .booktitle { font-size : 140% } .authors { font-size : 90%; line-height: 115%; } .moreauthors { font-size : 60% } #index #entrance { text-align: center; } #index #entrance .spacer { margin: 0 30px 0 30px; } ul.doclist { margin-top: 0em; margin-bottom: 0em; } #toc > * { clear: both; } #toc > a { display: block; float: left; margin-top: 1em; } #toc a h2{ display: inline; } aac-tactics-8.18.0/resources/footer.html0000644000175000017500000000041214463022056017601 0ustar jpuydtjpuydt aac-tactics-8.18.0/resources/header.html0000644000175000017500000000200114463022056017527 0ustar jpuydtjpuydt
aac-tactics-8.18.0/resources/config.js0000644000175000017500000000251314463022056017224 0ustar jpuydtjpuydtvar coqdocjs = coqdocjs || {}; coqdocjs.repl = { "forall": "∀", "exists": "∃", "~": "¬", "/\\": "∧", "\\/": "∨", "->": "→", "<-": "←", "<->": "↔", "=>": "⇒", "<>": "≠", "<=": "≤", ">=": "≥", "el": "∈", "nel": "∉", "<<=": "⊆", "|-": "⊢", ">>": "»", "<<": "⊆", "++": "⧺", "===": "≡", "=/=": "≢", "=~=": "≅", "==>": "⟹", "<==": "⟸", "False": "⊥", "True": "⊤", ":=": "≔", "-|": "⊣", "*": "×", "::": "∷", "lhd": "⊲", "rhd": "⊳", "nat": "ℕ", "alpha": "α", "beta": "β", "gamma": "γ", "delta": "δ", "epsilon": "ε", "eta": "η", "iota": "ι", "kappa": "κ", "lambda": "λ", "mu": "μ", "nu": "ν", "omega": "ω", "phi": "ϕ", "pi": "π", "psi": "ψ", "rho": "ρ", "sigma": "σ", "tau": "τ", "theta": "θ", "xi": "ξ", "zeta": "ζ", "Delta": "Δ", "Gamma": "Γ", "Pi": "Π", "Sigma": "Σ", "Omega": "Ω", "Xi": "Ξ" }; coqdocjs.subscr = { "0" : "₀", "1" : "₁", "2" : "₂", "3" : "₃", "4" : "₄", "5" : "₅", "6" : "₆", "7" : "₇", "8" : "₈", "9" : "₉", }; coqdocjs.replInText = ["==>","<=>", "=>", "->", "<-", ":="]; aac-tactics-8.18.0/Makefile.coq.local-late0000644000175000017500000000037414463022056017647 0ustar jpuydtjpuydtOCAMLDOCDIR = docs/ocamldoc ocamldoc: $(MLIFILES) $(SHOW)'OCAMLDOC -d $(OCAMLDOCDIR)' $(HIDE)mkdir -p $(OCAMLDOCDIR) $(HIDE)$(CAMLDOC) -d $(OCAMLDOCDIR) -html \ -m A $(CAMLDEBUG) $(CAMLDOCFLAGS) $(MLIFILES) $(FINDLIBPKGS) .PHONY: ocamldoc aac-tactics-8.18.0/theories/0000755000175000017500000000000014463022056015230 5ustar jpuydtjpuydtaac-tactics-8.18.0/theories/Instances.v0000644000175000017500000003566714463022056017367 0ustar jpuydtjpuydt(* *********************************************************************** *) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (* *********************************************************************** *) (** * Instances for AAC Tactics *) From Coq Require PeanoNat ZArith Zminmax NArith List Permutation. From Coq Require QArith Qminmax Relations. From AAC_tactics Require Export AAC. (** This one is not declared as an instance; this would interfere badly with setoid_rewrite *) Lemma eq_subr {X} {R} `{@Reflexive X R} : subrelation eq R. Proof. intros x y ->. reflexivity. Qed. Module Peano. Import PeanoNat. (** ** Peano instances *) #[export] Instance aac_Nat_add_Assoc : Associative eq Nat.add := Nat.add_assoc. #[export] Instance aac_Nat_add_Comm : Commutative eq Nat.add := Nat.add_comm. #[export] Instance aac_Nat_mul_Comm : Commutative eq Nat.mul := Nat.mul_comm. #[export] Instance aac_Nat_mul_Assoc : Associative eq Nat.mul := Nat.mul_assoc. #[export] Instance aac_Nat_min_Comm : Commutative eq Nat.min := Nat.min_comm. #[export] Instance aac_Nat_min_Assoc : Associative eq Nat.min := Nat.min_assoc. #[export] Instance aac_Nat_min_Idem : Idempotent eq Nat.min := Nat.min_idempotent. #[export] Instance aac_Nat_max_Comm : Commutative eq Nat.max := Nat.max_comm. #[export] Instance aac_Nat_max_Assoc : Associative eq Nat.max := Nat.max_assoc. #[export] Instance aac_Nat_max_Idem : Idempotent eq Nat.max := Nat.max_idempotent. #[export] Instance aac_Nat_mul_1_Unit : Unit eq Nat.mul 1 := Build_Unit eq Nat.mul 1 Nat.mul_1_l Nat.mul_1_r. #[export] Instance aac_Nat_add_0_Unit : Unit eq Nat.add 0 := Build_Unit eq Nat.add (0) Nat.add_0_l Nat.add_0_r. #[export] Instance aac_Nat_max_0_Unit : Unit eq Nat.max 0 := Build_Unit eq Nat.max 0 Nat.max_0_l Nat.max_0_r. (** We also provide liftings from [Nat.le] to [eq] *) #[export] Instance Nat_le_PreOrder : PreOrder Nat.le := Build_PreOrder _ Nat.le_refl Nat.le_trans. #[export] Instance aac_Nat_le_eq_lift : AAC_lift Nat.le eq := Build_AAC_lift eq_equivalence _. End Peano. Module Z. Import ZArith Zminmax. Open Scope Z_scope. (** ** Z instances *) #[export] Instance aac_Z_add_Assoc : Associative eq Z.add := Z.add_assoc. #[export] Instance aac_Z_add_Comm : Commutative eq Z.add := Z.add_comm. #[export] Instance aac_Z_mul_Comm : Commutative eq Z.mul := Z.mul_comm. #[export] Instance aac_Z_mul_Assoc : Associative eq Z.mul := Z.mul_assoc. #[export] Instance aac_Z_min_Comm : Commutative eq Z.min := Z.min_comm. #[export] Instance aac_Z_min_Assoc : Associative eq Z.min := Z.min_assoc. #[export] Instance aac_Z_min_Idem : Idempotent eq Z.min := Z.min_idempotent. #[export] Instance aac_Z_max_Comm : Commutative eq Z.max := Z.max_comm. #[export] Instance aac_Z_max_Assoc : Associative eq Z.max := Z.max_assoc. #[export] Instance aac_Z_max_Idem : Idempotent eq Z.max := Z.max_idempotent. #[export] Instance aac_Z_mul_1_Unit : Unit eq Z.mul 1 := Build_Unit eq Z.mul 1 Z.mul_1_l Z.mul_1_r. #[export] Instance aac_Z_add_0_Unit : Unit eq Z.add 0 := Build_Unit eq Z.add 0 Z.add_0_l Z.add_0_r. (** We also provide liftings from [Z.le] to [eq] *) #[export] Instance Z_le_PreOrder : PreOrder Z.le := Build_PreOrder _ Z.le_refl Z.le_trans. #[export] Instance aac_Z_le_eq_lift : AAC_lift Z.le eq := Build_AAC_lift eq_equivalence _. End Z. Module Lists. Import List Permutation. (** ** List instances *) #[export] Instance aac_List_app_Assoc {A} : Associative eq (@app A) := @app_assoc A. #[export] Instance aac_List_app_nil_Unit {A} : Unit eq (@app A) (@nil A) := Build_Unit _ (@app A) (@nil A) (@app_nil_l A) (@app_nil_r A). (** Exported [Morphisms] module provides a [Proper] instance *) #[export] Instance aac_List_app_Permutation_Assoc {A} : Associative (@Permutation A) (@app A). Proof. repeat intro; rewrite app_assoc; apply Permutation_refl. Qed. #[export] Instance aac_List_app_Permutation_Comm {A} : Commutative (@Permutation A) (@app A) := @Permutation_app_comm A. #[export] Instance aac_List_app_nil_Permutation_Unit {A} : Unit (@Permutation A) (@app A) (@nil A) := Build_Unit (@Permutation A) (@app A) (@nil A) (fun x => Permutation_refl x) (fun x => eq_ind_r (fun l => Permutation l _) (Permutation_refl x) (app_nil_r x)). (** [Permutation_app'] in the Stdlib provides a [Proper] instance *) End Lists. Module N. Import NArith. Open Scope N_scope. (** ** N instances *) #[export] Instance aac_N_add_Assoc : Associative eq N.add := N.add_assoc. #[export] Instance aac_N_add_Comm : Commutative eq N.add := N.add_comm. #[export] Instance aac_N_mul_Comm : Commutative eq N.mul := N.mul_comm. #[export] Instance aac_N_mul_Assoc : Associative eq N.mul := N.mul_assoc. #[export] Instance aac_N_min_Comm : Commutative eq N.min := N.min_comm. #[export] Instance aac_N_min_Assoc : Associative eq N.min := N.min_assoc. #[export] Instance aac_N_min_Idem : Idempotent eq N.min := N.min_idempotent. #[export] Instance aac_N_max_Comm : Commutative eq N.max := N.max_comm. #[export] Instance aac_N_max_Assoc : Associative eq N.max := N.max_assoc. #[export] Instance aac_N_max_Idem : Idempotent eq N.max := N.max_idempotent. #[export] Instance aac_N_mul_1_Unit : Unit eq N.mul (1)%N := Build_Unit eq N.mul (1)%N N.mul_1_l N.mul_1_r. #[export] Instance aac_N_add_0_Unit : Unit eq N.add (0)%N := Build_Unit eq N.add (0)%N N.add_0_l N.add_0_r. #[export] Instance aac_N_max_0_Unit : Unit eq N.max 0 := Build_Unit eq N.max 0 N.max_0_l N.max_0_r. (* We also provide liftings from [N.le] to [eq] *) #[export] Instance N_le_PreOrder : PreOrder N.le := Build_PreOrder N.le N.le_refl N.le_trans. #[export] Instance aac_N_le_eq_lift : AAC_lift N.le eq := Build_AAC_lift eq_equivalence _. End N. Module P. Import NArith. Open Scope positive_scope. (** ** Positive instances *) #[export] Instance aac_Pos_add_Assoc : Associative eq Pos.add := Pos.add_assoc. #[export] Instance aac_Pos_add_Comm : Commutative eq Pos.add := Pos.add_comm. #[export] Instance aac_Pos_mul_Comm : Commutative eq Pos.mul := Pos.mul_comm. #[export] Instance aac_Pos_mul_Assoc : Associative eq Pos.mul := Pos.mul_assoc. #[export] Instance aac_Pos_min_Comm : Commutative eq Pos.min := Pos.min_comm. #[export] Instance aac_Pos_min_Assoc : Associative eq Pos.min := Pos.min_assoc. #[export] Instance aac_Pos_min_Idem : Idempotent eq Pos.min := Pos.min_idempotent. #[export] Instance aac_Pos_max_Comm : Commutative eq Pos.max := Pos.max_comm. #[export] Instance aac_Pos_max_Assoc : Associative eq Pos.max := Pos.max_assoc. #[export] Instance aac_Pos_max_Idem : Idempotent eq Pos.max := Pos.max_idempotent. #[export] Instance aac_Pos_mul_1_Unit : Unit eq Pos.mul 1 := Build_Unit eq Pos.mul 1 Pos.mul_1_l Pos.mul_1_r. #[export] Instance aac_Pos_max_1_Unit : Unit eq Pos.max 1 := Build_Unit eq Pos.max 1 Pos.max_1_l Pos.max_1_r. (** We also provide liftings from [Pos.le] to [eq] *) #[export] Instance Pos_le_PreOrder : PreOrder Pos.le := Build_PreOrder Pos.le Pos.le_refl Pos.le_trans. #[export] Instance aac_Pos_le_eq_lift : AAC_lift Pos.le eq := Build_AAC_lift eq_equivalence _. End P. Module Q. Import QArith Qminmax. (** ** Q instances *) #[export] Instance aac_Q_Qplus_Qeq_Assoc : Associative Qeq Qplus := Qplus_assoc. #[export] Instance aac_Q_Qplus_Qeq_Comm : Commutative Qeq Qplus := Qplus_comm. #[export] Instance aac_Q_Qmult_Qeq_Comm : Commutative Qeq Qmult := Qmult_comm. #[export] Instance aac_Q_Qmult_Qeq_Assoc : Associative Qeq Qmult := Qmult_assoc. #[export] Instance aac_Q_Qmin_Qeq_Comm : Commutative Qeq Qmin := Q.min_comm. #[export] Instance aac_Q_Qmin_Qeq_Assoc : Associative Qeq Qmin := Q.min_assoc. #[export] Instance aac_Q_Qmin_Qeq_Idem : Idempotent Qeq Qmin := Q.min_idempotent. #[export] Instance aac_Q_Qmax_Qeq_Comm : Commutative Qeq Qmax := Q.max_comm. #[export] Instance aac_Q_Qmax_Qeq_Assoc : Associative Qeq Qmax := Q.max_assoc. #[export] Instance aac_Q_Qmax_Qeq_Idem : Idempotent Qeq Qmax := Q.max_idempotent. #[export] Instance aac_Q_Qmult_1_Qeq_Unit : Unit Qeq Qmult 1 := Build_Unit Qeq Qmult 1 Qmult_1_l Qmult_1_r. #[export] Instance aac_Q_Qplus_0_Qeq_Unit : Unit Qeq Qplus 0 := Build_Unit Qeq Qplus 0 Qplus_0_l Qplus_0_r. (** we also provide liftings from le to eq *) #[export] Instance Q_Qle_PreOrder : PreOrder Qle := Build_PreOrder Qle Qle_refl Qle_trans. #[export] Instance aac_Q_Qle_eq_lift : AAC_lift Qle Qeq := Build_AAC_lift QOrderedType.QOrder.TO.eq_equiv _. End Q. Module Prop_ops. (** ** Prop instances *) #[export] Instance aac_Prop_or_iff_Assoc : Associative iff or. Proof. unfold Associative; tauto. Qed. #[export] Instance aac_Prop_or_iff_Comm : Commutative iff or. Proof. unfold Commutative; tauto. Qed. #[export] Instance aac_Prop_or_iff_Idem : Idempotent iff or. Proof. unfold Idempotent; tauto. Qed. #[export] Instance aac_Prop_and_iff_Assoc : Associative iff and. Proof. unfold Associative; tauto. Qed. #[export] Instance aac_Prop_and_iff_Comm : Commutative iff and. Proof. unfold Commutative; tauto. Qed. #[export] Instance aac_Prop_and_iff_Idem : Idempotent iff and. Proof. unfold Idempotent; tauto. Qed. #[export] Instance aac_Prop_or_False_iff_Unit : Unit iff or False. Proof. constructor; firstorder. Qed. #[export] Instance aac_Prop_and_True_iff_Unit : Unit iff and True. Proof. constructor; firstorder. Qed. #[export] Program Instance not_iff_compat : Proper (iff ==> iff) not. Next Obligation. unfold iff; split; intros; tauto. Qed. Solve All Obligations with firstorder. #[export] Instance aac_Prop_impl_iff_lift : AAC_lift Basics.impl iff := Build_AAC_lift _ _. End Prop_ops. Module Bool. (** ** Boolean instances *) #[export] Instance aac_Bool_orb_Assoc : Associative eq orb. Proof. unfold Associative; firstorder with bool. Qed. #[export] Instance aac_Bool_orb_Comm : Commutative eq orb. Proof. unfold Commutative; firstorder with bool. Qed. #[export] Instance aac_Bool_orb_Idem : Idempotent eq orb. Proof. intro; apply Bool.orb_diag. Qed. #[export] Instance aac_Bool_andb_Assoc : Associative eq andb. Proof. unfold Associative; firstorder with bool. Qed. #[export] Instance aac_Bool_andb_Comm : Commutative eq andb. Proof. unfold Commutative; firstorder with bool. Qed. #[export] Instance aac_Bool_andb_Idem : Idempotent eq andb. Proof. intro; apply Bool.andb_diag. Qed. #[export] Instance aac_Bool_orb_false_Unit : Unit eq orb false. Proof. constructor; firstorder with bool. Qed. #[export] Instance aac_Bool_andb_true_Unit : Unit eq andb true. Proof. constructor; intros [|]; firstorder. Qed. #[export] Instance negb_compat : Proper (eq ==> eq) negb. Proof. intros [|] [|]; auto. Qed. End Bool. Module Relations. Import Relations.Relations. (** ** Relation instances *) Section defs. Variable T : Type. Variables R S: relation T. Definition inter : relation T := fun x y => R x y /\ S x y. Definition compo : relation T := fun x y => exists z : T, R x z /\ S z y. Definition negr : relation T := fun x y => ~ R x y. (** union and converse are already defined in the standard library *) Definition bot : relation T := fun _ _ => False. Definition top : relation T := fun _ _ => True. End defs. #[export] Instance same_relation_Equivalence T : Equivalence (same_relation T). Proof. firstorder. Qed. #[export] Instance aac_union_same_relation_Comm T : Commutative (same_relation T) (union T). Proof. unfold Commutative; compute; intuition. Qed. #[export] Instance aac_union_same_relation_Assoc T : Associative (same_relation T) (union T). Proof. unfold Associative; compute; intuition. Qed. #[export] Instance aac_union_same_relation_Idem T : Idempotent (same_relation T) (union T). Proof. unfold Idempotent; compute; intuition. Qed. #[export] Instance aac_bot_union_same_relation_Unit T : Unit (same_relation T) (union T) (bot T). Proof. constructor; compute; intuition. Qed. #[export] Instance aac_inter_same_relation_Comm T : Commutative (same_relation T) (inter T). Proof. unfold Commutative; compute; intuition. Qed. #[export] Instance aac_inter_same_relation_Assoc T : Associative (same_relation T) (inter T). Proof. unfold Associative; compute; intuition. Qed. #[export] Instance aac_inter_same_relation_Idem T : Idempotent (same_relation T) (inter T). Proof. unfold Idempotent; compute; intuition. Qed. #[export] Instance aac_inter_top_same_relation_Unit T : Unit (same_relation T) (inter T) (top T). Proof. constructor; compute; intuition. Qed. (** Note that we use [eq] directly as a neutral element for composition *) #[export] Instance aac_compo_same_relation_Assoc T : Associative (same_relation T) (compo T). Proof. unfold Associative; compute; firstorder. Qed. #[export] Instance aac_compo_eq_same_relation_Unit T : Unit (same_relation T) (compo T) (eq). Proof. compute; firstorder subst; trivial. Qed. #[export] Instance negr_same_relation_compat T : Proper (same_relation T ==> same_relation T) (negr T). Proof. compute. firstorder. Qed. #[export] Instance transp_same_relation_compat T : Proper (same_relation T ==> same_relation T) (transp T). Proof. compute. firstorder. Qed. #[export] Instance clos_trans_incr T : Proper (inclusion T ==> inclusion T) (clos_trans T). Proof. intros R S H x y Hxy. induction Hxy. constructor 1. apply H. assumption. econstructor 2; eauto 3. Qed. #[export] Instance clos_trans_same_relation_compat T : Proper (same_relation T ==> same_relation T) (clos_trans T). Proof. intros R S H; split; apply clos_trans_incr, H. Qed. #[export] Instance clos_refl_trans_incr T : Proper (inclusion T ==> inclusion T) (clos_refl_trans T). Proof. intros R S H x y Hxy. induction Hxy. constructor 1. apply H. assumption. constructor 2. econstructor 3; eauto 3. Qed. #[export] Instance clos_refl_trans_same_relation_compat T : Proper (same_relation T ==> same_relation T) (clos_refl_trans T). Proof. intros R S H; split; apply clos_refl_trans_incr, H. Qed. #[export] Instance inclusion_PreOrder T : PreOrder (inclusion T). Proof. constructor; unfold Reflexive, Transitive, inclusion; intuition. Qed. #[export] Program Instance aac_inclusion_same_relation_lift T : AAC_lift (inclusion T) (same_relation T) := Build_AAC_lift (same_relation_Equivalence T) _. Next Obligation. firstorder. Qed. End Relations. Module All. Export Peano. Export Z. Export Lists. Export P. Export N. Export Prop_ops. Export Bool. Export Relations. End All. (** Here, we should not see any instance of our classes: Print HintDb typeclass_instances. *) aac-tactics-8.18.0/theories/Constants.v0000644000175000017500000000332514463022056017376 0ustar jpuydtjpuydt(* *********************************************************************** *) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (* *********************************************************************** *) Register Init.Datatypes.O as aac_tactics.nat.O. Register Init.Datatypes.S as aac_tactics.nat.S. Register Init.Datatypes.nat as aac_tactics.nat.type. Register Init.Datatypes.pair as aac_tactics.pair.pair. Register Init.Datatypes.prod as aac_tactics.pair.prod. Register Init.Datatypes.option as aac_tactics.option.typ. Register Init.Datatypes.Some as aac_tactics.option.Some. Register Init.Datatypes.None as aac_tactics.option.None. Register Init.Datatypes.list as aac_tactics.list.typ. Register Init.Datatypes.nil as aac_tactics.list.nil. Register Init.Datatypes.cons as aac_tactics.list.cons. From Coq Require BinNums. Register BinNums.positive as aac_tactics.pos.typ. Register BinNums.xI as aac_tactics.pos.xI. Register BinNums.xO as aac_tactics.pos.xO. Register BinNums.xH as aac_tactics.pos.xH. From Coq Require Classes.Morphisms. Register Morphisms.Proper as aac_tactics.coq.classes.morphisms.Proper. From Coq Require Classes.RelationClasses. Register RelationClasses.Equivalence as aac_tactics.coq.RelationClasses.Equivalence. Register RelationClasses.Reflexive as aac_tactics.coq.RelationClasses.Reflexive. Register RelationClasses.Transitive as aac_tactics.coq.RelationClasses.Transitive. aac-tactics-8.18.0/theories/Utils.v0000644000175000017500000002035414463022056016523 0ustar jpuydtjpuydt(* *********************************************************************** *) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (* *********************************************************************** *) (** * Utility functions and results for AAC Tactics *) From Coq Require Import Arith NArith List RelationClasses. Set Implicit Arguments. Set Asymmetric Patterns. (** ** Utilities for positive numbers We use [positive] numbers as: - indices for morphisms and symbols - multiplicity of terms in sums *) Notation idx := positive. Fixpoint eq_idx_bool i j := match i,j with | xH, xH => true | xO i, xO j => eq_idx_bool i j | xI i, xI j => eq_idx_bool i j | _, _ => false end. Fixpoint idx_compare i j := match i,j with | xH, xH => Eq | xH, _ => Lt | _, xH => Gt | xO i, xO j => idx_compare i j | xI i, xI j => idx_compare i j | xI _, xO _ => Gt | xO _, xI _ => Lt end. Notation pos_compare := idx_compare (only parsing). (** Specification predicate for boolean binary functions *) Inductive decide_spec {A} {B} (R : A -> B -> Prop) (x : A) (y : B) : bool -> Prop := | decide_true : R x y -> decide_spec R x y true | decide_false : ~(R x y) -> decide_spec R x y false. Lemma eq_idx_spec : forall i j, decide_spec (@eq _) i j (eq_idx_bool i j). Proof. induction i; destruct j; simpl; try (constructor; congruence). case (IHi j); constructor; congruence. case (IHi j); constructor; congruence. Qed. (** Weak specification predicate for comparison functions: only the [Eq] case is specified *) Inductive compare_weak_spec A: A -> A -> comparison -> Prop := | pcws_eq: forall i, compare_weak_spec i i Eq | pcws_lt: forall i j, compare_weak_spec i j Lt | pcws_gt: forall i j, compare_weak_spec i j Gt. Lemma pos_compare_weak_spec: forall i j, compare_weak_spec i j (pos_compare i j). Proof. induction i; destruct j; simpl; try constructor; case (IHi j); intros; constructor. Qed. Lemma idx_compare_reflect_eq: forall i j, idx_compare i j = Eq -> i=j. Proof. intros i j. case (pos_compare_weak_spec i j); intros; congruence. Qed. (** ** Dependent types utilities *) Notation cast T H u := (eq_rect _ T u _ H). Section dep. Variable U: Type. Variable T: U -> Type. Lemma cast_eq: (forall u v: U, {u=v}+{u<>v}) -> forall A (H: A=A) (u: T A), cast T H u = u. Proof. intros. rewrite <- Eqdep_dec.eq_rect_eq_dec; trivial. Qed. Variable f: forall A B, T A -> T B -> comparison. Definition reflect_eqdep := forall A u B v (H: A=B), @f A B u v = Eq -> cast T H u = v. (** These lemmas have to remain transparent to get structural recursion in the lemma [tcompare_weak_spec] below *) Lemma reflect_eqdep_eq: reflect_eqdep -> forall A u v, @f A A u v = Eq -> u = v. Proof. intros H A u v He. apply (H _ _ _ _ eq_refl He). Defined. Lemma reflect_eqdep_weak_spec: reflect_eqdep -> forall A u v, compare_weak_spec u v (@f A A u v). Proof. intros. case_eq (f u v); try constructor. intro H'. apply reflect_eqdep_eq in H'. subst. constructor. assumption. Defined. End dep. (** ** Utilities about (non-empty) lists and multisets *) #[universes(template)] Inductive nelist (A : Type) : Type := | nil : A -> nelist A | cons : A -> nelist A -> nelist A. Register nil as aac_tactics.nelist.nil. Register cons as aac_tactics.nelist.cons. Notation "x :: y" := (cons x y). Fixpoint nelist_map (A B: Type) (f: A -> B) l := match l with | nil x => nil ( f x) | cons x l => cons ( f x) (nelist_map f l) end. Fixpoint appne A l l' : nelist A := match l with nil x => cons x l' | cons t q => cons t (appne A q l') end. Notation "x ++ y" := (appne x y). (** Finite multisets are represented with ordered lists with multiplicities *) Definition mset A := nelist (A*positive). (** Lexicographic composition of comparisons (this is a notation to keep it lazy) *) Notation lex e f := (match e with Eq => f | _ => e end). Section lists. (** Comparison functions *) Section c. Variables A B: Type. Variable compare: A -> B -> comparison. Fixpoint list_compare h k := match h,k with | nil x, nil y => compare x y | nil x, _ => Lt | _, nil x => Gt | u::h, v::k => lex (compare u v) (list_compare h k) end. End c. Definition mset_compare A B compare: mset A -> mset B -> comparison := list_compare (fun un vm => let '(u,n) := un in let '(v,m) := vm in lex (compare u v) (pos_compare n m)). Section list_compare_weak_spec. Variable A: Type. Variable compare: A -> A -> comparison. Hypothesis Hcompare: forall u v, compare_weak_spec u v (compare u v). (** This lemma has to remain transparent to get structural recursion in the lemma [tcompare_weak_spec] below *) Lemma list_compare_weak_spec: forall h k, compare_weak_spec h k (list_compare compare h k). Proof. induction h as [|u h IHh]; destruct k as [|v k]; simpl; try constructor. case (Hcompare a a0 ); try constructor. case (Hcompare u v ); try constructor. case (IHh k); intros; constructor. Defined. End list_compare_weak_spec. Section mset_compare_weak_spec. Variable A: Type. Variable compare: A -> A -> comparison. Hypothesis Hcompare: forall u v, compare_weak_spec u v (compare u v). (** This lemma has to remain transparent to get structural recursion in the lemma [tcompare_weak_spec] below *) Lemma mset_compare_weak_spec: forall h k, compare_weak_spec h k (mset_compare compare h k). Proof. apply list_compare_weak_spec. intros [u n] [v m]. case (Hcompare u v); try constructor. case (pos_compare_weak_spec n m); try constructor. Defined. End mset_compare_weak_spec. (** Merging functions (sorted) *) Section m. Variable A: Type. Variable compare: A -> A -> comparison. Definition insert n1 h1 := let fix insert_aux l2 := match l2 with | nil (h2,n2) => match compare h1 h2 with | Eq => nil (h1,Pplus n1 n2) | Lt => (h1,n1):: nil (h2,n2) | Gt => (h2,n2):: nil (h1,n1) end | (h2,n2)::t2 => match compare h1 h2 with | Eq => (h1,Pplus n1 n2):: t2 | Lt => (h1,n1)::l2 | Gt => (h2,n2)::insert_aux t2 end end in insert_aux. Fixpoint merge_msets l1 := match l1 with | nil (h1,n1) => fun l2 => insert n1 h1 l2 | (h1,n1)::t1 => let fix merge_aux l2 := match l2 with | nil (h2,n2) => match compare h1 h2 with | Eq => (h1,Pplus n1 n2) :: t1 | Lt => (h1,n1):: merge_msets t1 l2 | Gt => (h2,n2):: l1 end | (h2,n2)::t2 => match compare h1 h2 with | Eq => (h1,Pplus n1 n2)::merge_msets t1 t2 | Lt => (h1,n1)::merge_msets t1 l2 | Gt => (h2,n2)::merge_aux t2 end end in merge_aux end. (** Setting all multiplicities to one, in order to implement idempotency *) Definition reduce_mset: mset A -> mset A := nelist_map (fun x => (fst x,xH)). (** Interpretation of a list with a constant and a binary operation *) Variable B: Type. Variable map: A -> B. Variable b2: B -> B -> B. Fixpoint fold_map l := match l with | nil x => map x | u::l => b2 (map u) (fold_map l) end. (** Mapping and merging *) Variable merge: A -> nelist B -> nelist B. Fixpoint merge_map (l: nelist A): nelist B := match l with | nil x => nil (map x) | u::l => merge u (merge_map l) end. Variable ret : A -> B. Variable bind : A -> B -> B. Fixpoint fold_map' (l : nelist A) : B := match l with | nil x => ret x | u::l => bind u (fold_map' l) end. End m. End lists. aac-tactics-8.18.0/theories/dune0000644000175000017500000000042214463022056016104 0ustar jpuydtjpuydt(coq.theory (name AAC_tactics) (package coq-aac-tactics) (synopsis "Coq plugin providing tactics for rewriting universally quantified equations, modulo associative (and possibly commutative) operators") (libraries coq-aac-tactics.plugin) (flags :standard -w +default)) aac-tactics-8.18.0/theories/Caveats.v0000644000175000017500000002736514463022056017022 0ustar jpuydtjpuydt(* *********************************************************************** *) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (* *********************************************************************** *) (** * Currently known limitations and caveats of AAC Tactics *) From Coq Require NArith PeanoNat. From AAC_tactics Require Import AAC. From AAC_tactics Require Instances. (** ** Limitations *) (** *** Dependent parameters The type of the rewriting hypothesis must be of the form [forall (x_1: T_1) ... (x_n: T_n), R l r] where <> is a relation over some type <> and such that for all variable <> appearing in the left-hand side (<>), we actually have <>. The goal should be of the form <>, where <> is a relation on <>. In other words, we cannot instantiate arguments of an exogeneous type. *) Section parameters. Context {X} {R} {E: @Equivalence X R} {plus} {plus_A: Associative R plus} {plus_C: Commutative R plus} {plus_Proper: Proper (R ==> R ==> R) plus} {zero} {Zero: Unit R plus zero}. Notation "x == y" := (R x y) (at level 70). Notation "x + y" := (plus x y) (at level 50, left associativity). Notation "0" := (zero). Variable f : nat -> X -> X. (** In [Hf], since the parameter [n] has type [nat], it cannot be instantiated automatically *) Hypothesis Hf: forall n x, f n x + x == x. Hypothesis Hf': forall n, Proper (R ==> R) (f n). Goal forall a b k, a + f k (b+a) + b == a+b. intros. (** [aac_rewrite] does not instantiate [n] automatically *) Fail aac_rewrite Hf. (** of course, this argument can be given explicitly *) aac_rewrite (Hf k). aac_reflexivity. Qed. (** For the same reason, we cannot handle higher-order parameters (here, [g]) *) Hypothesis H : forall g x y, g x + g y == g (x + y). Variable g : X -> X. Hypothesis Hg : Proper (R ==> R) g. Goal forall a b c, g a + g b + g c == g (a + b + c). intros. Fail aac_rewrite H. do 2 aac_rewrite (H g). aac_reflexivity. Qed. End parameters. (** *** Exogeneous morphisms We do not handle "exogeneous" morphisms: morphisms that move from type <> to some other type <>. *) Section morphism. Import NArith PeanoNat. Import Instances.N Instances.Peano. Open Scope nat_scope. (** Typically, although [N_of_nat] is a proper morphism from [@eq nat] to [@eq N], we cannot rewrite under [N_of_nat] *) Goal forall a b: nat, N_of_nat (a+b-(b+a)) = 0%N. intros. Fail aac_rewrite Nat.sub_diag. Abort. (** More generally, this prevents us from rewriting under propositional contexts *) Context {P} {HP : Proper (@eq nat ==> iff) P}. Hypothesis H : P 0. Goal forall a b, P (a + b - (b + a)). intros a b. Fail aac_rewrite Nat.sub_diag. (** a solution is to introduce an evar to replace the part to be rewritten - this tiresome process should be improved in the future; here, it can be done using eapply and the morphism *) eapply HP. aac_rewrite Nat.sub_diag. reflexivity. exact H. Qed. Goal forall a b, a+b-(b+a) = 0 /\ b-b = 0. intros. (** similarly, we need to bring equations to the toplevel before being able to rewrite *) Fail aac_rewrite Nat.sub_diag. split; aac_rewrite Nat.sub_diag; reflexivity. Qed. End morphism. (** *** Treatment of variance with inequations We do not take variance into account when we compute the set of solutions to a matching problem modulo AC. As a consequence, [aac_instances] may propose solutions for which [aac_rewrite] will fail, due to the lack of adequate morphisms. *) Section ineq. Import ZArith. Import Instances.Z. Open Scope Z_scope. #[local] Instance Z_add_incr: Proper (Z.le ==> Z.le ==> Z.le) Z.add. Proof. intros ? ? H ? ? H'. apply Zplus_le_compat; assumption. Qed. Hypothesis H : forall x, x+x <= x. Goal forall a b c, c + - (a + a) + b + b <= c. intros. (** this fails because the first solution is not valid ([Z.opp] is not increasing) *) Fail aac_rewrite H. aac_instances H. (** on the contrary, the second solution is valid: *) aac_rewrite H at 1. (** currently, we cannot filter out such invalid solutions in an easy way; this should be fixed in the future *) Abort. End ineq. (** ** Caveats *) (** *** Special treatment for units [S 0] is considered as a unit for multiplication whenever a [Nat.mul] appears in the goal. The downside is that [S x] does not match [1], and [1] does not match [S (0 + 0)] whenever [Nat.mul] appears in the goal. *) Section Peano. Import Instances.Peano. Hypothesis H : forall x, x + S x = S (x+x). Goal 1 = 1. (** OK (no multiplication around), [x] is instantiated with [O] *) aacu_rewrite H. Abort. Goal 1 * 1 = 1. (** fails since 1 is seen as a unit, not the application of the morphism [S] to the constant [O] *) Fail aacu_rewrite H. Abort. Hypothesis H': forall x, x + 1 = 1 + x. Goal forall a, a + S (0+0) = 1 + a. (** OK (no multiplication around), [x] is instantiated with [a] *) intro. aac_rewrite H'. Abort. Goal forall a, a * a + S (0+0) = 1 + a * a. (** fails: although [S (0+0)] is understood as the application of the morphism [S] to the constant [O], it is not recognised as the unit [S O] of multiplication *) intro. Fail aac_rewrite H'. Abort. (** More generally, similar counter-intuitive behaviours can appear when declaring an applied morphism as a unit *) End Peano. (** *** Existential variables We implemented an algorithm for _matching_ modulo AC, not for _unifying_ modulo AC. As a consequence, existential variables appearing in a goal are considered as constants and will not be instantiated. *) Section evars. Import ZArith. Import Instances.Z. Variable P: Prop. Hypothesis H: forall x y, x + y + x = x -> P. Hypothesis idem: forall x, x + x = x. Goal P. eapply H. (** this works: [x] is instantiated with an evar *) aac_rewrite idem. instantiate (2 := 0). (** this does work but there are remaining evars in the end *) symmetry. aac_reflexivity. Abort. Hypothesis H': forall x, 3+x = x -> P. Goal P. eapply H'. (** this fails since we do not instantiate evars *) Fail aac_rewrite idem. Abort. End evars. (** *** Distinction between [aac_rewrite] and [aacu_rewrite] *) Section U. Context {X} {R} {E: @Equivalence X R} {dot} {dot_A: Associative R dot} {dot_Proper: Proper (R ==> R ==> R) dot} {one} {One: Unit R dot one}. Infix "==" := R (at level 70). Infix "*" := dot. Notation "1" := one. (** in some situations, the [aac_rewrite] tactic allows instantiations of a variable with a unit, when the variable occurs directly under a function symbol: *) Variable f : X -> X. Hypothesis Hf : Proper (R ==> R) f. Hypothesis dot_inv_left : forall x, f x*x == x. Goal f 1 == 1. aac_rewrite dot_inv_left. reflexivity. Qed. (** this behaviour seems desirable in most situations: these solutions with units are less peculiar than the other ones, since the unit comes from the goal; however, this policy is not properly enforced for now (hard to do with the current algorithm): *) Hypothesis dot_inv_right : forall x, x*f x == x. Goal f 1 == 1. Fail aac_rewrite dot_inv_right. aacu_rewrite dot_inv_right. reflexivity. Qed. End U. (** *** Rewriting units *) Section V. Context {X} {R} {E: @Equivalence X R} {dot} {dot_A: Associative R dot} {dot_Proper: Proper (R ==> R ==> R) dot} {one} {One: Unit R dot one}. Infix "==" := R (at level 70). Infix "*" := dot. Notation "1" := one. (** [aac_rewrite] uses the symbols appearing in the goal and the hypothesis to infer the AC and A operations. In the following example, [dot] appears neither in the left-hand-side of the goal, nor in the right-hand side of the hypothesis. Hence, [1] is not recognised as a unit. To circumvent this problem, we can force [aac_rewrite] to take into account a given operation, by giving it an extra argument. This extra argument seems useful only in this peculiar case. *) Lemma inv_unique: forall x y y', x*y == 1 -> y'*x == 1 -> y==y'. Proof. intros x y y' Hxy Hy'x. aac_instances <- Hy'x [dot]. aac_rewrite <- Hy'x at 1 [dot]. aac_rewrite Hxy. aac_reflexivity. Qed. End V. (** *** Rewriting too many things *) Section W. Import Instances.Peano. Variables a b c: nat. Hypothesis H: 0 = c. Goal b*(a+a) <= b*(c+a+a+1). (** [aac_rewrite] finds a pattern modulo AC that matches a given hypothesis, and then makes a call to [setoid_rewrite]. This [setoid_rewrite] can unfortunately make several rewrites (in a non-intuitive way: below, the [1] in the right-hand side is rewritten into [S c]) *) aac_rewrite H. (** to this end, we provide a companion tactic to [aac_rewrite] and [aacu_rewrite], that makes the transitivity step, but not the setoid_rewrite; this allows the user to select the relevant occurrences in which to rewrite: *) aac_pattern H at 2. setoid_rewrite H at 1. Abort. End W. (** *** Rewriting nullifiable patterns *) Section Z. Import Instances.Peano. (** If the pattern of the rewritten hypothesis does not contain "hard" symbols (like constants, function symbols, AC or A symbols without units), there can be infinitely many subterms such that the pattern matches: it is possible to build "subterms" modulo ACU that make the size of the term increase (by making neutral elements appear in a layered fashion). Hence, we settled with heuristics to propose only "some" of these solutions. In such cases, the tactic displays a (conservative) warning. *) Variables a b c: nat. Variable f: nat -> nat. Hypothesis H0: forall x, 0 = x - x. Hypothesis H1: forall x, 1 = x * x. Goal a + b * c = c. aac_instances H0. (** in this case, only three solutions are proposed, while there are infinitely many solutions, for example: - a+b*c*(1+[]) - a+b*c*(1+0*(1+ [])) - ... *) Abort. (** *** If the pattern is a unit or can be instantiated to be equal to a unit The heuristic is to make the unit appear at each possible position in the term, e.g. transforming [a] into [1*a] and [a*1], but this process is not recursive (we will not transform [1*a]) into [(1+0*1)*a]. *) Goal a+b+c = c. aac_instances H0 [mult]. (** 1 solution, we miss solutions like [(a+b+c*(1+0*(1+[])))] and so on *) aac_instances H1 [mult]. (** 7 solutions, we miss solutions like [(a+b+c+0*(1+0*[]))]*) Abort. (** *** Another example of the former case In the following, the hypothesis can be instantiated to be equal to [1]. *) Hypothesis H : forall x y, (x+y)*x = x*x + y*x. Goal a*a+b*a + c = c. (** here, only one solution if we use the aac_instance tactic *) aac_instances <- H. (** there are 8 solutions using [aacu_instances] (but, here, there are infinitely many different solutions); we miss, e.g., [a*a +b*a + (x*x + y*x)*c], which seems to be more peculiar *) aacu_instances <- H. (** the 7 last solutions are the same as if we were matching [1] *) aacu_instances H1. Abort. (** The behavior of the tactic is not satisfying in this case. It is still unclear how to handle properly this kind of situation; we plan to investigate this in the future. *) End Z. aac-tactics-8.18.0/theories/AAC.v0000644000175000017500000010123014463022056016000 0ustar jpuydtjpuydt(* *********************************************************************** *) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (* *********************************************************************** *) (** * Theory for AAC Tactics We define several base classes to package associative and possibly commutative/idempotent operators, and define a data-type for reified (or quoted) expressions (with morphisms). We then define a reflexive decision procedure to decide the equality of reified terms: first normalise reified terms, then compare them. This allows us to close transitivity steps automatically, in the [aac_rewrite] tactic. We restrict ourselves to the case where all symbols operate on a single fixed type. In particular, this means that we cannot handle situations like [H: forall x y, nat_of_pos (pos_of_nat (x) + y) + x = ...] where one occurrence of <<+>> operates on [nat] while the other one operates on [positive]. *) From Coq Require Import Arith NArith List. From Coq Require Import FMapPositive Relations RelationClasses. From Coq Require Export Morphisms. From AAC_tactics Require Import Utils Constants. Set Implicit Arguments. Set Asymmetric Patterns. Local Open Scope signature_scope. (** ** Environments for the reification process *) (** Positive maps are used to index elements *) Section sigma. Definition sigma := PositiveMap.t. Definition sigma_get A (null : A) (map : sigma A) (n : positive) : A := match PositiveMap.find n map with | None => null | Some x => x end. Definition sigma_add := @PositiveMap.add. Definition sigma_empty := @PositiveMap.empty. Register sigma_get as aac_tactics.sigma.get. Register sigma_add as aac_tactics.sigma.add. Register sigma_empty as aac_tactics.sigma.empty. End sigma. (** ** Classes for properties of operators *) Class Associative (X : Type) (R : relation X) (dot : X -> X -> X) := law_assoc : forall x y z, R (dot x (dot y z)) (dot (dot x y) z). Class Commutative (X : Type) (R : relation X) (plus : X -> X -> X) := law_comm: forall x y, R (plus x y) (plus y x). Class Idempotent (X : Type) (R : relation X) (plus : X -> X -> X) := law_idem: forall x, R (plus x x) x. Class Unit (X : Type) (R : relation X) (op : X -> X -> X) (unit : X) := { law_neutral_left: forall x, R (op unit x) x; law_neutral_right: forall x, R (op x unit) x }. Register Associative as aac_tactics.classes.Associative. Register Commutative as aac_tactics.classes.Commutative. Register Idempotent as aac_tactics.classes.Idempotent. Register Unit as aac_tactics.classes.Unit. (** Class used to find the equivalence relation on which operations are A or AC, starting from the relation appearing in the goal *) Class AAC_lift (X : Type) (R : relation X) (E : relation X) := { aac_lift_equivalence : Equivalence E; aac_list_proper : Proper (E ==> E ==> iff) R }. Register AAC_lift as aac_tactics.internal.AAC_lift. Register aac_lift_equivalence as aac_tactics.internal.aac_lift_equivalence. (** Simple instances for when we have a subrelation or an equivalence *) #[export] Instance aac_lift_subrelation {X} {R} {E} {HE: Equivalence E} {HR: @Transitive X R} {HER: subrelation E R} : AAC_lift R E | 3. Proof. constructor; trivial. intros ? ? H ? ? H'. split; intro G. rewrite <- H, G. apply HER, H'. rewrite H, G. apply HER. symmetry. apply H'. Qed. #[export] Instance aac_lift_proper {X} {R : relation X} {E} {HE: Equivalence E} {HR: Proper (E==>E==>iff) R} : AAC_lift R E | 4 := {}. (** ** Utilities for the evaluation function *) Module Internal. Section copy. Context {X} {R} {HR: @Equivalence X R} {plus} (op: Associative R plus) (op': Commutative R plus) (po: Proper (R ==> R ==> R) plus). (** <> (<> times) *) Fixpoint copy' n x := match n with | xH => x | xI n => let xn := copy' n x in plus (plus xn xn) x | xO n => let xn := copy' n x in (plus xn xn) end. Definition copy n x := Prect (fun _ => X) x (fun _ xn => plus x xn) n. Lemma copy_plus : forall n m x, R (copy (n+m) x) (plus (copy n x) (copy m x)). Proof. unfold copy. induction n using Pind; intros m x. rewrite Prect_base. rewrite <- Pplus_one_succ_l. rewrite Prect_succ. reflexivity. rewrite Pplus_succ_permute_l. rewrite 2Prect_succ. rewrite IHn. apply op. Qed. Lemma copy_xH : forall x, R (copy 1 x) x. Proof. intros; unfold copy; rewrite Prect_base. reflexivity. Qed. Lemma copy_Psucc : forall n x, R (copy (Pos.succ n) x) (plus x (copy n x)). Proof. intros; unfold copy; rewrite Prect_succ. reflexivity. Qed. #[export] Instance copy_compat n : Proper (R ==> R) (copy n). Proof. unfold copy. induction n using Pind; intros x y H. rewrite 2Prect_base. assumption. rewrite 2Prect_succ. apply po; auto. Qed. End copy. (** ** Packaging structures *) (** *** Free symbols *) Module Sym. Section t. Context {X} {R : relation X} . (** Type of an arity *) Fixpoint type_of (n: nat) := match n with | O => X | S n => X -> type_of n end. (** Relation to be preserved at an arity *) Fixpoint rel_of n : relation (type_of n) := match n with | O => R | S n => respectful R (rel_of n) end. Register type_of as aac_tactics.internal.sym.type_of. Register rel_of as aac_tactics.internal.sym.rel_of. (** A symbol package contains: - an arity, - a value of the corresponding type, and - a proof that the value is a proper morphism *) Record pack : Type := mkPack { ar : nat; value :> type_of ar; morph : Proper (rel_of ar) value }. Register pack as aac_tactics.sym.pack. Register mkPack as aac_tactics.sym.mkPack. (** Helper to build default values, when filling reification environments *) Definition null: pack := mkPack 1 (fun x => x) (fun _ _ H => H). Register null as aac_tactics.sym.null. End t. End Sym. (** *** Binary operations *) Module Bin. Section t. Context {X} {R: relation X}. Record pack := mk_pack { value:> X -> X -> X; compat: Proper (R ==> R ==> R) value; assoc: Associative R value; comm: option (Commutative R value); idem: option (Idempotent R value) }. Register pack as aac_tactics.bin.pack. Register mk_pack as aac_tactics.bin.mkPack. End t. (** See the <> module for concrete instances of these classes *) End Bin. (** ** Reification, normalisation, and decision *) Section s. Context {X} {R: relation X} {E: @Equivalence X R}. Infix "==" := R (at level 80). (** We use environments to store the various operators and the morphisms *) Variable e_sym: idx -> @Sym.pack X R. Variable e_bin: idx -> @Bin.pack X R. (** Packaging units (depends on [e_bin]) *) Record unit_of u := mk_unit_for { uf_idx: idx; uf_desc: Unit R (Bin.value (e_bin uf_idx)) u }. Record unit_pack := mk_unit_pack { u_value:> X; u_desc: list (unit_of u_value) }. Register unit_of as aac_tactics.internal.unit_of. Register mk_unit_for as aac_tactics.internal.mk_unit_for. Register unit_pack as aac_tactics.internal.unit_pack. Register mk_unit_pack as aac_tactics.internal.mk_unit_pack. Variable e_unit: positive -> unit_pack. #[local] Hint Resolve e_bin e_unit: typeclass_instances. (** *** Almost normalised syntax A term in [T] is in normal form if: - sums do not contain sums - products do not contain products - there are no unary sums or products - lists and msets are lexicographically sorted according to the order we define below [vT n] denotes the set of term vectors of size <> (the mutual dependency could be removed). Note that [T] and [vT] depend on the [e_sym] environment (which contains, among other things, the arity of symbols). *) Inductive T: Type := | sum: idx -> mset T -> T | prd: idx -> nelist T -> T | sym: forall i, vT (Sym.ar (e_sym i)) -> T | unit : idx -> T with vT: nat -> Type := | vnil: vT O | vcons: forall n, T -> vT n -> vT (S n). Register T as aac_tactics.internal.T. Register sum as aac_tactics.internal.sum. Register prd as aac_tactics.internal.prd. Register sym as aac_tactics.internal.sym. Register unit as aac_tactics.internal.unit. Register vnil as aac_tactics.internal.vnil. Register vcons as aac_tactics.internal.vcons. (** Lexicographic rpo over the normalised syntax *) Fixpoint compare (u v: T) := match u,v with | sum i l, sum j vs => lex (idx_compare i j) (mset_compare compare l vs) | prd i l, prd j vs => lex (idx_compare i j) (list_compare compare l vs) | sym i l, sym j vs => lex (idx_compare i j) (vcompare l vs) | unit i , unit j => idx_compare i j | unit _ , _ => Lt | _ , unit _ => Gt | sum _ _, _ => Lt | _ , sum _ _ => Gt | prd _ _, _ => Lt | _ , prd _ _ => Gt end with vcompare i j (us: vT i) (vs: vT j) := match us,vs with | vnil, vnil => Eq | vnil, _ => Lt | _, vnil => Gt | vcons _ u us, vcons _ v vs => lex (compare u v) (vcompare us vs) end. (** *** Evaluation from syntax to the abstract domain *) Fixpoint eval u: X := match u with | sum i l => let o := Bin.value (e_bin i) in fold_map (fun un => let '(u,n):=un in @copy _ o n (eval u)) o l | prd i l => fold_map eval (Bin.value (e_bin i)) l | sym i v => eval_aux v (Sym.value (e_sym i)) | unit i => e_unit i end with eval_aux i (v: vT i): Sym.type_of i -> X := match v with | vnil => fun f => f | vcons _ u v => fun f => eval_aux v (f (eval u)) end. Register eval as aac_tactics.internal.eval. (** We need to show that [compare] reflects equality (this is because we work with msets rather than with lists with arities) *) Fixpoint tcompare_weak_spec u : forall (v : T), compare_weak_spec u v (compare u v) with vcompare_reflect_eqdep i us : forall j vs (H: i=j), vcompare us vs = Eq -> cast vT H us = vs. Proof. induction u. - destruct v; simpl; try constructor. case (pos_compare_weak_spec p p0); intros; try constructor. case (mset_compare_weak_spec compare tcompare_weak_spec m m0); intros; try constructor. - destruct v; simpl; try constructor. case (pos_compare_weak_spec p p0); intros; try constructor. case (list_compare_weak_spec compare tcompare_weak_spec n n0); intros; try constructor. - destruct v0; simpl; try constructor. case_eq (idx_compare i i0); intro Hi; try constructor. (* the [symmetry] is required *) apply idx_compare_reflect_eq in Hi. symmetry in Hi. subst. case_eq (vcompare v v0); intro Hv; try constructor. rewrite <- (vcompare_reflect_eqdep _ _ _ _ eq_refl Hv). constructor. - destruct v; simpl; try constructor. case_eq (idx_compare p p0); intro Hi; try constructor. apply idx_compare_reflect_eq in Hi. symmetry in Hi. subst. constructor. - induction us; destruct vs; simpl; intros H Huv; try discriminate. apply cast_eq, eq_nat_dec. injection H; intro Hn. revert Huv; case (tcompare_weak_spec t t0); intros; try discriminate. (* the [symmetry] is required *) symmetry in Hn. subst. rewrite <- (IHus _ _ eq_refl Huv). apply cast_eq, eq_nat_dec. Qed. Instance eval_aux_compat i (l: vT i): Proper (@Sym.rel_of X R i ==> R) (eval_aux l). Proof. induction l; simpl; repeat intro. assumption. apply IHl, H. reflexivity. Qed. (** Is <> a unit for <>? *) Definition is_unit_of j i := List.existsb (fun p => eq_idx_bool j (uf_idx p)) (u_desc (e_unit i)). (** Is <> commutative? *) Definition is_commutative i := match Bin.comm (e_bin i) with Some _ => true | None => false end. (** Is <> idempotent? *) Definition is_idempotent i := match Bin.idem (e_bin i) with Some _ => true | None => false end. (** *** Normalisation *) #[universes(template)] Inductive discr {A} : Type := | Is_op : A -> discr | Is_unit : idx -> discr | Is_nothing : discr. (** This is called [Datatypes.sum] in the stdlib *) #[universes(template)] Inductive m {A} {B} := | left : A -> m | right : B -> m. Definition comp A B (merge : B -> B -> B) (l : B) (l' : @m A B) : @m A B := match l' with | left _ => right l | right l' => right (merge l l') end. (** Auxiliary functions, to clean up sums *) Section sums. Variable i : idx. Variable is_unit : idx -> bool. Definition sum' (u: mset T): T := match u with | nil (u,xH) => u | _ => sum i u end. Definition is_sum (u: T) : @discr (mset T) := match u with | sum j l => if eq_idx_bool j i then Is_op l else Is_nothing | unit j => if is_unit j then Is_unit j else Is_nothing | _ => Is_nothing end. Definition copy_mset n (l: mset T): mset T := match n with | xH => l | _ => nelist_map (fun vm => let '(v,m):=vm in (v,Pmult n m)) l end. Definition return_sum u n := match is_sum u with | Is_nothing => right (nil (u,n)) | Is_op l' => right (copy_mset n l') | Is_unit j => left j end. Definition add_to_sum u n (l : @m idx (mset T)) := match is_sum u with | Is_nothing => comp (merge_msets compare) (nil (u,n)) l | Is_op l' => comp (merge_msets compare) (copy_mset n l') l | Is_unit _ => l end. Definition norm_msets_ norm (l: mset T) := fold_map' (fun un => let '(u,n) := un in return_sum (norm u) n) (fun un l => let '(u,n) := un in add_to_sum (norm u) n l) l. End sums. (** Similar functions for products *) Section prds. Variable i : idx. Variable is_unit : idx -> bool. Definition prd' (u: nelist T): T := match u with | nil u => u | _ => prd i u end. Definition is_prd (u: T) : @discr (nelist T) := match u with | prd j l => if eq_idx_bool j i then Is_op l else Is_nothing | unit j => if is_unit j then Is_unit j else Is_nothing | _ => Is_nothing end. Definition return_prd u := match is_prd u with | Is_nothing => right (nil (u)) | Is_op l' => right (l') | Is_unit j => left j end. Definition add_to_prd u (l : @m idx (nelist T)) := match is_prd u with | Is_nothing => comp (@appne T) (nil (u)) l | Is_op l' => comp (@appne T) (l') l | Is_unit _ => l end. Definition norm_lists_ norm (l : nelist T) := fold_map' (fun u => return_prd (norm u)) (fun u l => add_to_prd (norm u) l) l. End prds. Definition run_list x := match x with | left n => nil (unit n) | right l => l end. Definition norm_lists norm i l := let is_unit := is_unit_of i in run_list (norm_lists_ i is_unit norm l). Definition run_msets x := match x with | left n => nil (unit n, xH) | right l => l end. Definition norm_msets norm i l := let is_unit := is_unit_of i in run_msets (norm_msets_ i is_unit norm l). Fixpoint norm u {struct u}:= match u with | sum i l => if is_commutative i then if is_idempotent i then sum' i (reduce_mset (norm_msets norm i l)) else sum' i (norm_msets norm i l) else u | prd i l => prd' i (norm_lists norm i l) | sym i l => sym i (vnorm l) | unit i => unit i end with vnorm i (l: vT i): vT i := match l with | vnil => vnil | vcons _ u l => vcons (norm u) (vnorm l) end. (** *** Correctness *) Lemma is_unit_of_Unit : forall i j : idx, is_unit_of i j = true -> Unit R (Bin.value (e_bin i)) (eval (unit j)). Proof. intros. unfold is_unit_of in H. rewrite existsb_exists in H. destruct H as [x [H H']]. revert H' ; case (eq_idx_spec); [intros H' _ ; subst| intros _ H'; discriminate]. simpl. destruct x. simpl. auto. Qed. Instance Binvalue_Commutative i (H : is_commutative i = true) : Commutative R (@Bin.value _ _ (e_bin i) ). Proof. unfold is_commutative in H. destruct (Bin.comm (e_bin i)); auto. discriminate. Qed. Instance Binvalue_Idempotent i (H : is_idempotent i = true) : Idempotent R (@Bin.value _ _ (e_bin i)). Proof. unfold is_idempotent in H. destruct (Bin.idem (e_bin i)); auto. discriminate. Qed. Instance Binvalue_Associative i : Associative R (@Bin.value _ _ (e_bin i)). Proof. destruct ((e_bin i)); auto. Qed. Instance Binvalue_Proper i : Proper (R ==> R ==> R) (@Bin.value _ _ (e_bin i) ). Proof. destruct ((e_bin i)); auto. Qed. #[local] Hint Resolve Binvalue_Proper Binvalue_Associative Binvalue_Commutative : core. #[local] Hint Resolve is_unit_of_Unit : core. (** Auxiliary lemmas about sums *) Section sum_correctness. Variable i : idx. Variable is_unit : idx -> bool. Hypothesis is_unit_sum_Unit : forall j, is_unit j = true -> @Unit X R (Bin.value (e_bin i)) (eval (unit j)). Inductive is_sum_spec_ind : T -> @discr (mset T) -> Prop := | is_sum_spec_op : forall j l, j = i -> is_sum_spec_ind (sum j l) (Is_op l) | is_sum_spec_unit : forall j, is_unit j = true -> is_sum_spec_ind (unit j) (Is_unit j) | is_sum_spec_nothing : forall u, is_sum_spec_ind u (Is_nothing). Lemma is_sum_spec u : is_sum_spec_ind u (is_sum i is_unit u). Proof. unfold is_sum; case u; intros; try constructor. case_eq (eq_idx_bool p i); intros; subst; try constructor; auto. revert H. case eq_idx_spec; try discriminate. auto. case_eq (is_unit p); intros; try constructor. auto. Qed. Instance assoc : @Associative X R (Bin.value (e_bin i)). Proof. destruct (e_bin i). simpl. assumption. Qed. Instance proper : Proper (R ==> R ==> R)(Bin.value (e_bin i)). Proof. destruct (e_bin i). simpl. assumption. Qed. Hypothesis comm : @Commutative X R (Bin.value (e_bin i)). Lemma sum'_sum : forall (l: mset T), eval (sum' i l) == eval (sum i l). Proof. intros [[a n] | [a n] l]; destruct n; simpl; reflexivity. Qed. Lemma eval_sum_nil x : eval (sum i (nil (x,xH))) == (eval x). Proof. rewrite <- sum'_sum. reflexivity. Qed. Lemma eval_sum_cons : forall n a (l: mset T), (eval (sum i ((a,n)::l))) == (@Bin.value _ _ (e_bin i) (@copy _ (@Bin.value _ _ (e_bin i)) n (eval a)) (eval (sum i l))). Proof. intros n a [[? ? ]|[b m] l]; simpl; reflexivity. Qed. Inductive compat_sum_unit : @m idx (mset T) -> Prop := | csu_left : forall x, is_unit x = true-> compat_sum_unit (left x) | csu_right : forall m, compat_sum_unit (right m). Lemma compat_sum_unit_return x n : compat_sum_unit (return_sum i is_unit x n). Proof. unfold return_sum. case is_sum_spec; intros; try constructor; auto. Qed. Lemma compat_sum_unit_add : forall x n h, compat_sum_unit h -> compat_sum_unit (add_to_sum i (is_unit_of i) x n h). Proof. unfold add_to_sum;intros; inversion H; case_eq (is_sum i (is_unit_of i) x); intros; simpl; try constructor || eauto. apply H0. Qed. (* Hint Resolve copy_plus. : this lags because of the inference of the implicit arguments *) #[local] Hint Extern 5 (copy (?n + ?m) (eval ?a) == Bin.value (copy ?n (eval ?a)) (copy ?m (eval ?a))) => apply copy_plus : core. #[local] Hint Extern 5 (?x == ?x) => reflexivity : core. #[local] Hint Extern 5 ( Bin.value ?x ?y == Bin.value ?y ?x) => apply Bin.comm : core. Lemma eval_merge_bin : forall (h k: mset T), eval (sum i (merge_msets compare h k)) == @Bin.value _ _ (e_bin i) (eval (sum i h)) (eval (sum i k)). Proof. induction h as [[a n]|[a n] h IHh]; intro k. - simpl; induction k as [[b m]|[b m] k IHk]; simpl. * destruct (tcompare_weak_spec a b) as [a|a b|a b]; simpl; auto. apply copy_plus; auto. * destruct (tcompare_weak_spec a b) as [a|a b|a b]; simpl; auto. rewrite copy_plus,law_assoc; auto. rewrite IHk; clear IHk. rewrite 2 law_assoc. apply proper; [apply law_comm|reflexivity]. - induction k as [[b m]|[b m] k IHk]; simpl; simpl in IHh. * destruct (tcompare_weak_spec a b) as [a|a b|a b]; simpl. rewrite (law_comm _ (copy m (eval a))). rewrite law_assoc, <- copy_plus, Pplus_comm; auto. rewrite <- law_assoc, IHh. reflexivity. rewrite law_comm. reflexivity. * simpl in IHk. destruct (tcompare_weak_spec a b) as [a|a b|a b]; simpl. rewrite IHh; clear IHh. rewrite 2 law_assoc. rewrite (law_comm _ (copy m (eval a))). rewrite law_assoc, <- copy_plus, Pplus_comm; auto. rewrite IHh; clear IHh. simpl. rewrite law_assoc. reflexivity. rewrite 2 (law_comm (copy m (eval b))). rewrite law_assoc. apply proper; [ | reflexivity]. rewrite <- IHk. reflexivity. Qed. Lemma copy_mset' n (l: mset T) : copy_mset n l = nelist_map (fun vm => let '(v,m):=vm in (v,Pmult n m)) l. Proof. unfold copy_mset. destruct n; try reflexivity. simpl. induction l as [|[a l] IHl]; simpl; try congruence. destruct a; reflexivity. Qed. Lemma copy_mset_succ n (l: mset T) : eval (sum i (copy_mset (Pos.succ n) l)) == @Bin.value _ _ (e_bin i) (eval (sum i l)) (eval (sum i (copy_mset n l))). Proof. rewrite 2 copy_mset'. induction l as [[a m]|[a m] l IHl]. simpl eval. rewrite <- copy_plus; auto. rewrite Pmult_Sn_m. reflexivity. simpl nelist_map. rewrite ! eval_sum_cons. rewrite IHl. clear IHl. rewrite Pmult_Sn_m. rewrite copy_plus; auto. rewrite <- !law_assoc. apply Binvalue_Proper; try reflexivity. rewrite law_comm . rewrite <- !law_assoc. apply proper; try reflexivity. apply law_comm. Qed. Lemma copy_mset_copy : forall n (m : mset T), eval (sum i (copy_mset n m)) == @copy _ (@Bin.value _ _ (e_bin i)) n (eval (sum i m)). Proof. induction n using Pind; intros. - unfold copy_mset. rewrite copy_xH. reflexivity. - rewrite copy_mset_succ. rewrite copy_Psucc. rewrite IHn. reflexivity. Qed. Instance compat_sum_unit_Unit : forall p, compat_sum_unit (left p) -> @Unit X R (Bin.value (e_bin i)) (eval (unit p)). Proof. intros; inversion H; subst; auto. Qed. Lemma copy_n_unit : forall j n, is_unit j = true -> eval (unit j) == @copy _ (Bin.value (e_bin i)) n (eval (unit j)). Proof. intros; induction n using Prect. rewrite copy_xH. reflexivity. rewrite copy_Psucc. rewrite <- IHn. apply is_unit_sum_Unit in H. rewrite law_neutral_left. reflexivity. Qed. Lemma z0 l r (H : compat_sum_unit r) : eval (sum i (run_msets (comp (merge_msets compare) l r))) == eval (sum i ((merge_msets compare) (l) (run_msets r))). Proof. unfold comp. unfold run_msets. case_eq r; intros; subst; [|reflexivity]. rewrite eval_merge_bin; auto. rewrite eval_sum_nil. apply compat_sum_unit_Unit in H. rewrite law_neutral_right. reflexivity. Qed. Lemma z1 : forall n x, eval (sum i (run_msets (return_sum i (is_unit) x n ))) == @copy _ (@Bin.value _ _ (e_bin i)) n (eval x). Proof. intros; unfold return_sum, run_msets. case (is_sum_spec); intros; subst. - rewrite copy_mset_copy; reflexivity. - rewrite eval_sum_nil. apply copy_n_unit. auto. - reflexivity. Qed. Lemma z2 : forall u n x, compat_sum_unit x -> eval (sum i (run_msets (add_to_sum i (is_unit) u n x))) == @Bin.value _ _ (e_bin i) (@copy _ (@Bin.value _ _ (e_bin i)) n (eval u)) (eval (sum i (run_msets x))). Proof. intros u n x Hix. unfold add_to_sum. case is_sum_spec; intros; subst. - rewrite z0 by auto. rewrite eval_merge_bin, copy_mset_copy. reflexivity. - rewrite <- copy_n_unit by assumption. apply is_unit_sum_Unit in H. rewrite law_neutral_left. reflexivity. - rewrite z0 by auto. rewrite eval_merge_bin. reflexivity. Qed. End sum_correctness. Lemma eval_norm_msets i norm (Comm : Commutative R (Bin.value (e_bin i))) (Hnorm: forall u, eval (norm u) == eval u) : forall h, eval (sum i (norm_msets norm i h)) == eval (sum i h). Proof. unfold norm_msets. assert (H : forall h : mset T, eval (sum i (run_msets (norm_msets_ i (is_unit_of i) norm h))) == eval (sum i h) /\ compat_sum_unit (is_unit_of i) (norm_msets_ i (is_unit_of i) norm h)). induction h as [[a n] | [a n] h [IHh IHh']]; simpl norm_msets_; split. - rewrite z1 by auto. rewrite Hnorm. reflexivity. - apply compat_sum_unit_return. - rewrite z2 by auto. rewrite IHh, eval_sum_cons, Hnorm. reflexivity. - apply compat_sum_unit_add, IHh'. - apply H. Defined. Lemma copy_idem i (Idem : Idempotent R (Bin.value (e_bin i))) n x : copy (plus:=(Bin.value (e_bin i))) n x == x. Proof. induction n using Pos.peano_ind; simpl. - apply copy_xH. - rewrite copy_Psucc, IHn; apply law_idem. Qed. Lemma eval_reduce_msets i (Idem : Idempotent R (Bin.value (e_bin i))) m : eval (sum i (reduce_mset m)) == eval (sum i m). Proof. induction m as [[a n]|[a n] m IH]. - simpl. now rewrite 2copy_idem. - simpl. rewrite IH. now rewrite 2copy_idem. Qed. (** Auxiliary lemmas about products *) Section prd_correctness. Variable i : idx. Variable is_unit : idx -> bool. Hypothesis is_unit_prd_Unit : forall j, is_unit j = true -> @Unit X R (Bin.value (e_bin i)) (eval (unit j)). Inductive is_prd_spec_ind : T -> @discr (nelist T) -> Prop := | is_prd_spec_op : forall j l, j = i -> is_prd_spec_ind (prd j l) (Is_op l) | is_prd_spec_unit : forall j, is_unit j = true -> is_prd_spec_ind (unit j) (Is_unit j) | is_prd_spec_nothing : forall u, is_prd_spec_ind u (Is_nothing). Lemma is_prd_spec u : is_prd_spec_ind u (is_prd i is_unit u). Proof. unfold is_prd; case u; intros; try constructor. case (eq_idx_spec); intros; subst; try constructor; auto. case_eq (is_unit p); intros; try constructor; auto. Qed. Lemma prd'_prd : forall (l: nelist T), eval (prd' i l) == eval (prd i l). Proof. intros [?|? [|? ?]]; simpl; reflexivity. Qed. Lemma eval_prd_nil x: eval (prd i (nil x)) == eval x. Proof. rewrite <- prd'_prd. simpl. reflexivity. Qed. Lemma eval_prd_cons a : forall (l: nelist T), eval (prd i (a::l)) == @Bin.value _ _ (e_bin i) (eval a) (eval (prd i l)). Proof. intros [|b l]; simpl; reflexivity. Qed. Lemma eval_prd_app : forall (h k: nelist T), eval (prd i (h++k)) == @Bin.value _ _ (e_bin i) (eval (prd i h)) (eval (prd i k)). Proof. induction h; intro k. simpl; try reflexivity. simpl appne. rewrite 2 eval_prd_cons, IHh, law_assoc. reflexivity. Qed. Inductive compat_prd_unit : @m idx (nelist T) -> Prop := | cpu_left : forall x, is_unit x = true -> compat_prd_unit (left x) | cpu_right : forall m, compat_prd_unit (right m). Lemma compat_prd_unit_return x : compat_prd_unit (return_prd i is_unit x). Proof. unfold return_prd. case (is_prd_spec); intros; try constructor; auto. Qed. Lemma compat_prd_unit_add : forall x h, compat_prd_unit h -> compat_prd_unit (add_to_prd i is_unit x h). Proof. intros; unfold add_to_prd, comp. case (is_prd_spec); intros; try constructor; auto. - unfold comp; case h; try constructor. - unfold comp; case h; try constructor. Qed. Instance compat_prd_Unit : forall p, compat_prd_unit (left p) -> @Unit X R (Bin.value (e_bin i)) (eval (unit p)). Proof. intros. inversion H; subst. apply is_unit_prd_Unit. assumption. Qed. Lemma z0' : forall l (r: @m idx (nelist T)), compat_prd_unit r -> eval (prd i (run_list (comp (@appne T) l r))) == eval (prd i ((appne (l) (run_list r)))). Proof. intros. unfold comp. unfold run_list. case_eq r; intros; auto; subst. rewrite eval_prd_app. rewrite eval_prd_nil. apply compat_prd_Unit in H. rewrite law_neutral_right. reflexivity. reflexivity. Qed. Lemma z1' a : eval (prd i (run_list (return_prd i is_unit a))) == eval (prd i (nil a)). Proof. intros. unfold return_prd. unfold run_list. case (is_prd_spec); intros; subst; reflexivity. Qed. Lemma z2' : forall u x, compat_prd_unit x -> eval (prd i (run_list (add_to_prd i is_unit u x))) == @Bin.value _ _ (e_bin i) (eval u) (eval (prd i (run_list x))). Proof. intros u x Hix. unfold add_to_prd. case (is_prd_spec); intros; subst. rewrite z0' by auto. rewrite eval_prd_app. reflexivity. apply is_unit_prd_Unit in H. rewrite law_neutral_left. reflexivity. rewrite z0' by auto. rewrite eval_prd_app. reflexivity. Qed. End prd_correctness. Lemma eval_norm_lists i (Hnorm: forall u, eval (norm u) == eval u) : forall h, eval (prd i (norm_lists norm i h)) == eval (prd i h). Proof. unfold norm_lists. assert (H : forall h : nelist T, eval (prd i (run_list (norm_lists_ i (is_unit_of i) norm h))) == eval (prd i h) /\ compat_prd_unit (is_unit_of i) (norm_lists_ i (is_unit_of i) norm h)). { induction h as [a | a h [IHh IHh']]; simpl norm_lists_; split. rewrite z1'. simpl. apply Hnorm. apply compat_prd_unit_return. rewrite z2'. rewrite IHh. rewrite eval_prd_cons. rewrite Hnorm. reflexivity. apply is_unit_of_Unit. auto. apply compat_prd_unit_add. auto. } apply H. Defined. (** Correctness of the normalisation function *) Fixpoint eval_norm u: eval (norm u) == eval u with eval_norm_aux i l : forall (f: Sym.type_of i), Proper (@Sym.rel_of X R i) f -> eval_aux (vnorm l) f == eval_aux l f. Proof. induction u as [ p m | p l | ? | ?]; simpl norm. - case_eq (is_commutative p); intros. case_eq (is_idempotent p); intros. rewrite sum'_sum. rewrite eval_reduce_msets. 2: eauto with typeclass_instances. apply eval_norm_msets; auto. rewrite sum'_sum. apply eval_norm_msets; auto. reflexivity. - rewrite prd'_prd. apply eval_norm_lists; auto. - apply eval_norm_aux, Sym.morph. - reflexivity. - induction l; simpl; intros f Hf. reflexivity. rewrite eval_norm. apply IHl, Hf; reflexivity. Qed. (** Corollaries, for goal normalisation or decision *) Lemma normalise : forall (u v: T), eval (norm u) == eval (norm v) -> eval u == eval v. Proof. intros u v. rewrite 2 eval_norm. trivial. Qed. Lemma compare_reflect_eq: forall u v, compare u v = Eq -> eval u == eval v. Proof. intros u v. case (tcompare_weak_spec u v); intros; try congruence. reflexivity. Qed. Lemma decide: forall (u v: T), compare (norm u) (norm v) = Eq -> eval u == eval v. Proof. intros u v H. apply normalise. apply compare_reflect_eq. apply H. Qed. Register decide as aac_tactics.internal.decide. Lemma lift_normalise {S} {H : AAC_lift S R} : forall (u v: T), (let x := norm u in let y := norm v in S (eval x) (eval y)) -> S (eval u) (eval v). Proof. destruct H. intros u v; simpl; rewrite 2 eval_norm. trivial. Qed. Register lift_normalise as aac_tactics.internal.lift_normalise. End s. End Internal. Local Ltac internal_normalize := let x := fresh in let y := fresh in intro x; intro y; vm_compute in x; vm_compute in y; unfold x; unfold y; compute [Internal.eval Utils.fold_map Internal.copy Prect]; simpl. (** ** Lemmas for performing transitivity steps given an AAC_lift instance *) Section t. Context `{AAC_lift}. Lemma lift_transitivity_left (y x z : X): E x y -> R y z -> R x z. Proof. destruct H as [Hequiv Hproper]; intros G;rewrite G. trivial. Qed. Lemma lift_transitivity_right (y x z : X): E y z -> R x y -> R x z. Proof. destruct H as [Hequiv Hproper]; intros G. rewrite G. trivial. Qed. Lemma lift_reflexivity {HR :Reflexive R}: forall x y, E x y -> R x y. Proof. destruct H. intros ? ? G. rewrite G. reflexivity. Qed. Register lift_transitivity_left as aac_tactics.internal.lift_transitivity_left. Register lift_transitivity_right as aac_tactics.internal.lift_transitivity_right. Register lift_reflexivity as aac_tactics.internal.lift_reflexivity. End t. Declare ML Module "aac_plugin:coq-aac-tactics.plugin". aac-tactics-8.18.0/theories/Tutorial.v0000644000175000017500000003327314463022056017232 0ustar jpuydtjpuydt(* *********************************************************************** *) (* This is part of aac_tactics, it is distributed under the terms of the *) (* GNU Lesser General Public License version 3 *) (* (see file LICENSE for more details) *) (* *) (* Copyright 2009-2010: Thomas Braibant, Damien Pous. *) (* *********************************************************************** *) (** * Tutorial for using AAC Tactics *) From Coq Require PeanoNat ZArith List Permutation Lia. From AAC_tactics Require Import AAC. From AAC_tactics Require Instances. (** ** Introductory example Here is a first example with relative numbers ([Z]): one can rewrite an universally quantified hypothesis modulo the associativity and commutativity of [Z.add]. *) Section introduction. Import ZArith. Import Instances.Z. Variables a b c : Z. Hypothesis H: forall x, x + Z.opp x = 0. Goal a + b + c + Z.opp (c + a) = b. aac_rewrite H. aac_reflexivity. Qed. Goal a + c + Z.opp (b + a + Z.opp b) = c. do 2 aac_rewrite H. reflexivity. Qed. (** note: - the tactic handles arbitrary function symbols like [Z.opp] (as long as they are proper morphisms w.r.t. the considered equivalence relation) - here, the [ring] tactic would have done the job *) (** several associative/commutative operations can be used at the same time, here, [Z.mul] and [Z.add], which are both associative and commutative (AC) *) Goal (b + c) * (c + b) + a + Z.opp ((c + b) * (b + c)) = a. aac_rewrite H. aac_reflexivity. Qed. (** some commutative operations can be declared as idempotent, here [Z.max] which is taken into account by the [aac_normalise] and [aac_reflexivity] tactics; however, [aac_rewrite] does not match modulo idempotency *) Goal Z.max (b + c) (c + b) + a + Z.opp (c + b) = a. aac_normalise. aac_rewrite H. aac_reflexivity. Qed. Goal Z.max c (Z.max b c) + a + Z.opp (Z.max c b) = a. aac_normalise. aac_rewrite H. aac_reflexivity. Qed. End introduction. (** ** Usage One can also work in an abstract context, with arbitrary associative and commutative operators. (Note that one can declare several operations of each kind.) *) Section base. Context {X} {R} {E: Equivalence R} {plus} {dot} {zero} {one} {dot_A: @Associative X R dot } {plus_A: @Associative X R plus } {plus_C: @Commutative X R plus } {dot_Proper :Proper (R ==> R ==> R) dot} {plus_Proper :Proper (R ==> R ==> R) plus} {Zero : Unit R plus zero} {One : Unit R dot one}. Notation "x == y" := (R x y) (at level 70). Notation "x * y" := (dot x y) (at level 40, left associativity). Notation "1" := (one). Notation "x + y" := (plus x y) (at level 50, left associativity). Notation "0" := (zero). (** in the very first example, [ring] would have solved the goal; here, since [dot] does not necessarily distribute over [plus], it is not possible to rely on it *) Section reminder. Hypothesis H : forall x, x * x == x. Variables a b c : X. Goal (a+b+c)*(c+a+b) == a+b+c. aac_rewrite H. aac_reflexivity. Qed. (** the tactic starts by normalising terms, so that trailing units are always eliminated *) Goal ((a+b)+0+c)*((c+a)+b*1) == a+b+c. aac_rewrite H. aac_reflexivity. Qed. End reminder. (** the tactic can deal with "proper" morphisms of arbitrary arity (here [f] and [g], or [Z.opp] earlier): it rewrites under such morphisms ([g]), and, more importantly, it is able to reorder terms modulo AC under these morphisms ([f]) *) Section morphisms. Variable f : X -> X -> X. Hypothesis Hf : Proper (R ==> R ==> R) f. Variable g : X -> X. Hypothesis Hg : Proper (R ==> R) g. Variable a b: X. Hypothesis H : forall x y, x+f (b+y) x == y+x. Goal g ((f (a+b) a) + a) == g (a+a). aac_rewrite H. reflexivity. Qed. End morphisms. (** *** Selecting what and where to rewrite There are sometimes several solutions to the matching problem. We now show how to interact with the tactic to select the desired one. *) Section occurrence. Variable f : X -> X. Variable a : X. Hypothesis Hf : Proper (R ==> R) f. Hypothesis H : forall x, x + x == x. Goal f(a+a)+f(a+a) == f a. (* in case there are several possible solutions, one can print the different solutions using the [aac_instances] tactic (in ProofGeneral, look at the *coq* buffer): *) aac_instances H. (* the default choice is the occurrence with the smallest possible context (number 0), but one can choose the desired one *) aac_rewrite H at 1. (* now the goal is [f a + f a == f a], there is only one solution *) aac_rewrite H. reflexivity. Qed. End occurrence. Section subst. Variables a b c d : X. Hypothesis H: forall x y, a*x*y*b == a*(x+y)*b. Hypothesis H': forall x, x + x == x. Goal a*c*d*c*d*b == a*c*d*b. (* here, there is only one possible occurrence, but several substitutions: *) aac_instances H. (* one can select them with the proper keyword: *) aac_rewrite H subst 1. aac_rewrite H'. aac_reflexivity. Qed. End subst. (** As expected, one can use both keywords together to select the occurrence and the substitution. We also provide a keyword to specify that the rewrite should be done in the right-hand side of the equation. *) Section both. Variables a b c d : X. Hypothesis H: forall x y, a*x*y*b == a*(x+y)*b. Hypothesis H': forall x, x + x == x. Goal a*c*d*c*d*b*b == a*(c*d*b)*b. aac_instances H. aac_rewrite H at 1 subst 1. aac_instances H. aac_rewrite H. aac_rewrite H'. aac_rewrite H at 0 subst 1 in_right. aac_reflexivity. Qed. End both. (** *** Distinction between [aac_rewrite] and [aacu_rewrite]: [aac_rewrite] rejects solutions in which variables are instantiated by units, while the companion tactic, [aacu_rewrite] allows such solutions. *) Section dealing_with_units. Variables a b c: X. Hypothesis H: forall x, a*x*a == x. Goal a*a == 1. (* here, [x] must be instantiated with [1], so that the [aac_*] tactics give no solutions: *) try aac_instances H. (* while we get solutions with the [aacu_*] tactics: *) aacu_instances H. aacu_rewrite H. reflexivity. Qed. (** we introduced this distinction because it allows us to rule out dummy cases in common situations: *) Hypothesis H': forall x y z, x*y + x*z == x*(y+z). Goal a*b*c + a*c + a*b == a*(c+b*(1+c)). (* 6 solutions without units *) aac_instances H'. aac_rewrite H' at 0. (* more than 52 with units *) aacu_instances H'. Abort. End dealing_with_units. End base. (** *** Declaring instances To use one's own operations: it suffices to declare them as instances of our classes. (Note that the following instances are already declared in the Instances module.) *) Section Peano. Import PeanoNat. #[local] Instance aac_Nat_add_Assoc : Associative eq Nat.add := Nat.add_assoc. #[local] Instance aac_Nat_add_Comm : Commutative eq Nat.add := Nat.add_comm. #[local] Instance aac_Nat_mul_Comm : Commutative eq Nat.mul := Nat.mul_comm. #[local] Instance aac_Nat_mul_Assoc : Associative eq Nat.mul := Nat.mul_assoc. #[local] Instance aac_Nat_mul_1_Unit : Unit eq Nat.mul 1 := Build_Unit eq Nat.mul 1 Nat.mul_1_l Nat.mul_1_r. #[local] Instance aac_Nat_add_0_Unit : Unit eq Nat.add 0 := Build_Unit eq Nat.add (O) Nat.add_0_l Nat.add_0_r. (** Two (or more) operations may share the same units: in the following example, [0] is understood as the unit of [Nat.max] as well as the unit of [Nat.add]. *) #[local] Instance aac_Nat_max_Comm : Commutative eq Nat.max := Nat.max_comm. #[local] Instance aac_Nat_max_Assoc : Associative eq Nat.max := Nat.max_assoc. (** Commutative operations may additionally be declared as idempotent. This does not change the behaviour of [aac_rewrite], but this enables more simplifications in [aac_normalise] and [aac_reflexivity]. *) #[local] Instance aac_Nat_max_Idem : Idempotent eq Nat.max := Nat.max_idempotent. #[local] Instance aac_Nat_max_0_Unit : Unit eq Nat.max 0 := Build_Unit eq Nat.max 0 Nat.max_0_l Nat.max_0_r. Variable a b c : nat. Goal Nat.max (a + 0) 0 = a. aac_reflexivity. Qed. (** here, we use idempotency: *) Goal Nat.max (a + 0) a = a. aac_reflexivity. Qed. (** furthermore, several operators can be mixed: *) Hypothesis H : forall x y z, Nat.max (x + y) (x + z) = x + Nat.max y z. Goal Nat.max (a + b) (c + (a * 1)) = Nat.max c b + a. aac_instances H. aac_rewrite H. aac_reflexivity. Qed. Goal Nat.max (a + b) (c + Nat.max (a*1+0) 0) = a + Nat.max b c. aac_instances H. aac_rewrite H. aac_reflexivity. Qed. (** *** Working with inequations To be able to use the tactics, the goal must be a relation [R] applied to two arguments, and the rewritten hypothesis must end with a relation [Q] applied to two arguments. These relations are not necessarily equivalences, but they should be related according to the occurrence where the rewrite takes place; we leave this check to the underlying call to [setoid_rewrite]. *) (** one can rewrite equations in the left member of inequations: *) Goal (forall x, x + x = x) -> a + b + b + a <= a + b. intro Hx. aac_rewrite Hx. reflexivity. Qed. (** or in the right member of inequations, using the [in_right] keyword: *) Goal (forall x, x + x = x) -> a + b <= a + b + b + a. intro Hx. aac_rewrite Hx in_right. reflexivity. Qed. (** similarly, one can rewrite inequations in inequations: *) Goal (forall x, x + x <= x) -> a + b + b + a <= a + b. intro Hx. aac_rewrite Hx. reflexivity. Qed. (** possibly in the right-hand side: *) Goal (forall x, x <= x + x) -> a + b <= a + b + b + a. intro Hx. aac_rewrite <- Hx in_right. reflexivity. Qed. (** [aac_reflexivity] deals with "trivial" inequations too: *) Goal Nat.max (a + b) (c + a) <= Nat.max (b + a) (c + 1*a). aac_reflexivity. Qed. (** In the last three examples, there were no equivalence relations involved in the goal. However, we actually had to guess the equivalence relation with respect to which the operators ([add,max,0]) were AC. In this case, it was Leibniz equality [eq] so that it was automatically inferred; more generally, one can specify which equivalence relation to use by declaring instances of the [AAC_lift] type class: *) #[local] Instance aac_le_eq_lift : AAC_lift le eq := {}. (** (This instance is automatically inferred because [eq] is always a valid candidate, here for [le].) *) End Peano. (** *** Normalising goals We also provide a tactic to normalise terms modulo AC. This normalisation is the one we use internally. *) Section AAC_normalise. Import Instances.Z. Import ZArith. Open Scope Z_scope. Variable a b c d : Z. Goal a + (b + c*c*d) + a + 0 + d*1 = a. aac_normalise. Abort. Goal Z.max (a+b) (b+a) = a+b. aac_reflexivity. Show Proof. Abort. End AAC_normalise. (** ** Examples from previous website *) Section Examples. Import Instances.Z. Import ZArith Lia. Open Scope Z_scope. (** *** Reverse triangle inequality *) Lemma Z_abs_triangle : forall x y, Z.abs (x + y) <= Z.abs x + Z.abs y. Proof Z.abs_triangle. Lemma Z_add_opp_diag_r : forall x, x + -x = 0. Proof Z.add_opp_diag_r. (** the following morphisms are required to perform the required rewrites: *) #[local] Instance Z_opp_ge_le_compat : Proper (Z.ge ==> Z.le) Z.opp. Proof. intros x y. lia. Qed. #[local] Instance Z_add_le_compat : Proper (Z.le ==> Z.le ==> Z.le) Z.add. Proof. intros ? ? ? ? ? ?; lia. Qed. Goal forall a b, Z.abs a - Z.abs b <= Z.abs (a - b). intros. unfold Z.sub. aac_instances <- (Z.sub_diag b). aac_rewrite <- (Z.sub_diag b) at 3. unfold Z.sub. aac_rewrite Z_abs_triangle. aac_rewrite Z_add_opp_diag_r. aac_reflexivity. Qed. (** *** Pythagorean triples *) Notation "x ^2" := (x*x) (at level 40). Notation "2 ⋅ x" := (x+x) (at level 41). Lemma Hbin1: forall x y, (x+y)^2 = x^2 + y^2 + 2⋅x*y. Proof. intros; ring. Qed. Lemma Hbin2: forall x y, x^2 + y^2 = (x+y)^2 + -(2⋅x*y). Proof. intros; ring. Qed. Lemma Hopp : forall x, x + -x = 0. Proof. apply Zplus_opp_r. Qed. Variables a b c : Z. Hypothesis H : c^2 + 2⋅(a+1)*b = (a+1+b)^2. Goal a^2 + b^2 + 2⋅a + 1 = c^2. aacu_rewrite <- Hbin1. rewrite Hbin2. aac_rewrite <- H. aac_rewrite Hopp. aac_reflexivity. Qed. (** note: after the [aac_rewrite <- H], one could use [ring] to close the proof *) End Examples. (** ** List examples *) Section Lists. Import List Permutation. Import Instances.Lists. Variables (X : Type) (l1 l2 l3 : list X). Goal l1 ++ (l2 ++ l3) = (l1 ++ l2) ++ l3. aac_reflexivity. Qed. Goal Permutation (l1 ++ l2) (l2 ++ l1). aac_reflexivity. Qed. Hypothesis H : Permutation l1 l2. Goal Permutation (l1 ++ l3) (l3 ++ l2). aac_rewrite H. aac_reflexivity. Qed. End Lists. (** ** Prop examples *) Section Props. Import Instances.Prop_ops. Variables (P Q : Prop). Goal (Q /\ P) <-> (P /\ (Q /\ True)). aac_reflexivity. Qed. Goal (Q \/ P) <-> (P \/ (Q \/ False)). aac_reflexivity. Qed. End Props. aac-tactics-8.18.0/.github/0000755000175000017500000000000014463022056014746 5ustar jpuydtjpuydtaac-tactics-8.18.0/.github/workflows/0000755000175000017500000000000014463022056017003 5ustar jpuydtjpuydtaac-tactics-8.18.0/.github/workflows/docker-action.yml0000644000175000017500000000153314463022056022252 0ustar jpuydtjpuydtname: Docker CI on: push: branches: - v8.18 pull_request: branches: - '**' jobs: build: # the OS must be GNU/Linux to be able to use the docker-coq-action runs-on: ubuntu-latest strategy: matrix: image: - 'coqorg/coq:dev' fail-fast: false steps: - uses: actions/checkout@v3 - uses: coq-community/docker-coq-action@v1 with: opam_file: 'coq-aac-tactics.opam' custom_image: ${{ matrix.image }} before_install: | startGroup "Print opam config and unpin dune" opam config list; opam repo list; opam list; opam pin remove coq-core coq-stdlib coqide-server coq -y endGroup # See also: # https://github.com/coq-community/docker-coq-action#readme # https://github.com/erikmd/docker-coq-github-action-demo aac-tactics-8.18.0/meta.yml0000644000175000017500000000775514463022056015075 0ustar jpuydtjpuydt--- fullname: AAC Tactics shortname: aac-tactics organization: coq-community community: true action: true nix: true plugin: true doi: 10.1007/978-3-642-25379-9_14 branch: 'v8.18' coqdoc: true coqdoc_index: docs/coqdoc/toc.html synopsis: >- Coq tactics for rewriting universally quantified equations, modulo associative (and possibly commutative and idempotent) operators description: |- This Coq plugin provides tactics for rewriting and proving universally quantified equations modulo associativity and commutativity of some operator, with idempotent commutative operators enabling additional simplifications. The tactics can be applied for custom operators by registering the operators and their properties as type class instances. Instances for many commonly used operators, such as for binary integer arithmetic and booleans, are provided with the plugin. publications: - pub_doi: 10.1007/978-3-642-25379-9_14 pub_url: https://arxiv.org/abs/1106.4448 pub_title: Tactics for Reasoning modulo AC in Coq authors: - name: Thomas Braibant initial: true - name: Damien Pous initial: true - name: Fabian Kunze initial: false maintainers: - name: Karl Palmskog nickname: palmskog opam-file-maintainer: palmskog@gmail.com opam-file-version: 8.18.dev license: fullname: GNU Lesser General Public License v3.0 or later identifier: LGPL-3.0-or-later supported_coq_versions: text: 8.18 (use the corresponding branch or release for other Coq versions) opam: '{>= "8.18" & < "8.19"}' supported_ocaml_versions: text: 4.09.0 or later opam: '{>= "4.09.0"}' tested_coq_nix_versions: - coq_version: '8.18' tested_coq_opam_versions: - version: '8.18' namespace: AAC_tactics keywords: - name: reflexive tactic - name: rewriting - name: rewriting modulo associativity and commutativity - name: rewriting modulo ac - name: decision procedure categories: - name: Miscellaneous/Coq Extensions - name: Computer Science/Decision Procedures and Certified Algorithms/Decision procedures documentation: | ## Documentation The following example shows an application of the tactics for reasoning over Z binary numbers: ```coq From AAC_tactics Require Import AAC. From AAC_tactics Require Instances. From Coq Require Import ZArith. Section ZOpp. Import Instances.Z. Variables a b c : Z. Hypothesis H: forall x, x + Z.opp x = 0. Goal a + b + c + Z.opp (c + a) = b. aac_rewrite H. aac_reflexivity. Qed. Goal Z.max (b + c) (c + b) + a + Z.opp (c + b) = a. aac_normalise. aac_rewrite H. aac_reflexivity. Qed. End ZOpp. ``` The file [Tutorial.v](theories/Tutorial.v) provides a succinct introduction and more examples of how to use this plugin. The file [Instances.v](theories/Instances.v) defines several type class instances for frequent use-cases of this plugin, that should allow you to use it off-the-shelf. Namely, it contains instances for: - Peano naturals (`Import Instances.Peano.`) - Z binary numbers (`Import Instances.Z.`) - Lists (`Import Instances.Lists.`) - N binary numbers (`Import Instances.N.`) - Positive binary numbers (`Import Instances.P.`) - Rational numbers (`Import Instances.Q.`) - Prop (`Import Instances.Prop_ops.`) - Booleans (`Import Instances.Bool.`) - Relations (`Import Instances.Relations.`) - all of the above (`Import Instances.All.`) To understand the inner workings of the tactics, please refer to the `.mli` files as the main source of information on each `.ml` file. See also the [latest coqdoc documentation](https://coq-community.org/aac-tactics/docs/coqdoc/toc.html) and the [latest ocamldoc documentation](https://coq-community.org/aac-tactics/docs/ocamldoc/index.html). ## Acknowledgements The initial authors are grateful to Evelyne Contejean, Hugo Herbelin, Assia Mahboubi, and Matthieu Sozeau for highly instructive discussions. The plugin took inspiration from the plugin tutorial "constructors" by Matthieu Sozeau, distributed under the LGPL 2.1. --- aac-tactics-8.18.0/README.md0000644000175000017500000001223314463022056014666 0ustar jpuydtjpuydt # AAC Tactics [![Docker CI][docker-action-shield]][docker-action-link] [![Nix CI][nix-action-shield]][nix-action-link] [![Contributing][contributing-shield]][contributing-link] [![Code of Conduct][conduct-shield]][conduct-link] [![Zulip][zulip-shield]][zulip-link] [![coqdoc][coqdoc-shield]][coqdoc-link] [![DOI][doi-shield]][doi-link] [docker-action-shield]: https://github.com/coq-community/aac-tactics/workflows/Docker%20CI/badge.svg?branch=v8.18 [docker-action-link]: https://github.com/coq-community/aac-tactics/actions?query=workflow:"Docker%20CI" [nix-action-shield]: https://github.com/coq-community/aac-tactics/workflows/Nix%20CI/badge.svg?branch=v8.18 [nix-action-link]: https://github.com/coq-community/aac-tactics/actions?query=workflow:"Nix%20CI" [contributing-shield]: https://img.shields.io/badge/contributions-welcome-%23f7931e.svg [contributing-link]: https://github.com/coq-community/manifesto/blob/master/CONTRIBUTING.md [conduct-shield]: https://img.shields.io/badge/%E2%9D%A4-code%20of%20conduct-%23f15a24.svg [conduct-link]: https://github.com/coq-community/manifesto/blob/master/CODE_OF_CONDUCT.md [zulip-shield]: https://img.shields.io/badge/chat-on%20zulip-%23c1272d.svg [zulip-link]: https://coq.zulipchat.com/#narrow/stream/237663-coq-community-devs.20.26.20users [coqdoc-shield]: https://img.shields.io/badge/docs-coqdoc-blue.svg [coqdoc-link]: https://coq-community.org/aac-tactics/docs/coqdoc/toc.html [doi-shield]: https://zenodo.org/badge/DOI/10.1007/978-3-642-25379-9_14.svg [doi-link]: https://doi.org/10.1007/978-3-642-25379-9_14 This Coq plugin provides tactics for rewriting and proving universally quantified equations modulo associativity and commutativity of some operator, with idempotent commutative operators enabling additional simplifications. The tactics can be applied for custom operators by registering the operators and their properties as type class instances. Instances for many commonly used operators, such as for binary integer arithmetic and booleans, are provided with the plugin. ## Meta - Author(s): - Thomas Braibant (initial) - Damien Pous (initial) - Fabian Kunze - Coq-community maintainer(s): - Karl Palmskog ([**@palmskog**](https://github.com/palmskog)) - License: [GNU Lesser General Public License v3.0 or later](LICENSE) - Compatible Coq versions: 8.18 (use the corresponding branch or release for other Coq versions) - Compatible OCaml versions: 4.09.0 or later - Additional dependencies: none - Coq namespace: `AAC_tactics` - Related publication(s): - [Tactics for Reasoning modulo AC in Coq](https://arxiv.org/abs/1106.4448) doi:[10.1007/978-3-642-25379-9_14](https://doi.org/10.1007/978-3-642-25379-9_14) ## Building and installation instructions The easiest way to install the latest released version of AAC Tactics is via [OPAM](https://opam.ocaml.org/doc/Install.html): ```shell opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-aac-tactics ``` To instead build and install manually, do: ``` shell git clone https://github.com/coq-community/aac-tactics.git cd aac-tactics make # or make -j make install ``` ## Documentation The following example shows an application of the tactics for reasoning over Z binary numbers: ```coq From AAC_tactics Require Import AAC. From AAC_tactics Require Instances. From Coq Require Import ZArith. Section ZOpp. Import Instances.Z. Variables a b c : Z. Hypothesis H: forall x, x + Z.opp x = 0. Goal a + b + c + Z.opp (c + a) = b. aac_rewrite H. aac_reflexivity. Qed. Goal Z.max (b + c) (c + b) + a + Z.opp (c + b) = a. aac_normalise. aac_rewrite H. aac_reflexivity. Qed. End ZOpp. ``` The file [Tutorial.v](theories/Tutorial.v) provides a succinct introduction and more examples of how to use this plugin. The file [Instances.v](theories/Instances.v) defines several type class instances for frequent use-cases of this plugin, that should allow you to use it off-the-shelf. Namely, it contains instances for: - Peano naturals (`Import Instances.Peano.`) - Z binary numbers (`Import Instances.Z.`) - Lists (`Import Instances.Lists.`) - N binary numbers (`Import Instances.N.`) - Positive binary numbers (`Import Instances.P.`) - Rational numbers (`Import Instances.Q.`) - Prop (`Import Instances.Prop_ops.`) - Booleans (`Import Instances.Bool.`) - Relations (`Import Instances.Relations.`) - all of the above (`Import Instances.All.`) To understand the inner workings of the tactics, please refer to the `.mli` files as the main source of information on each `.ml` file. See also the [latest coqdoc documentation](https://coq-community.org/aac-tactics/docs/coqdoc/toc.html) and the [latest ocamldoc documentation](https://coq-community.org/aac-tactics/docs/ocamldoc/index.html). ## Acknowledgements The initial authors are grateful to Evelyne Contejean, Hugo Herbelin, Assia Mahboubi, and Matthieu Sozeau for highly instructive discussions. The plugin took inspiration from the plugin tutorial "constructors" by Matthieu Sozeau, distributed under the LGPL 2.1. aac-tactics-8.18.0/_CoqProject0000644000175000017500000000074414463022056015546 0ustar jpuydtjpuydt-generate-meta-for-package coq-aac-tactics -Q theories AAC_tactics -Q src AAC_tactics -I src -arg -w -arg +default src/coq.mli src/helper.mli src/search_monad.mli src/matcher.mli src/theory.mli src/print.mli src/aac_rewrite.mli src/coq.ml src/helper.ml src/search_monad.ml src/matcher.ml src/theory.ml src/print.ml src/aac_rewrite.ml src/aac.mlg src/aac_plugin.mlpack theories/Utils.v theories/Constants.v theories/AAC.v theories/Instances.v theories/Tutorial.v theories/Caveats.v aac-tactics-8.18.0/Makefile0000644000175000017500000000051714463022056015051 0ustar jpuydtjpuydtall: Makefile.coq @+$(MAKE) -f Makefile.coq all clean: Makefile.coq @+$(MAKE) -f Makefile.coq cleanall @rm -f Makefile.coq Makefile.coq.conf Makefile.coq: _CoqProject $(COQBIN)coq_makefile -f _CoqProject -o Makefile.coq force _CoqProject Makefile: ; %: Makefile.coq force @+$(MAKE) -f Makefile.coq $@ .PHONY: all clean force