pax_global_header00006660000000000000000000000064145402622340014514gustar00rootroot0000000000000052 comment=de92ae50c05c5c3420f5ffffdf603316e401118f paramcoq-1.1.3-coq8.19/000077500000000000000000000000001454026223400144215ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/.github/000077500000000000000000000000001454026223400157615ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/.github/workflows/000077500000000000000000000000001454026223400200165ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/.github/workflows/docker-action.yml000066400000000000000000000015461454026223400232710ustar00rootroot00000000000000# This file was generated from `meta.yml`, please do not edit manually. # Follow the instructions on https://github.com/coq-community/templates to regenerate. name: Docker CI on: push: branches: - v8.19 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:8.19' fail-fast: false steps: - uses: actions/checkout@v3 - uses: coq-community/docker-coq-action@v1 with: opam_file: 'coq-paramcoq.opam' custom_image: ${{ matrix.image }} export: 'OPAMWITHTEST' env: OPAMWITHTEST: 'true' # See also: # https://github.com/coq-community/docker-coq-action#readme # https://github.com/erikmd/docker-coq-github-action-demo paramcoq-1.1.3-coq8.19/.gitignore000066400000000000000000000006571454026223400164210ustar00rootroot00000000000000# Generated Makefile Makefile.coq Makefile.coq.conf META.coq-paramcoq META # Dune _build # Make dependencies *.d # Backup files *.bak # emacs backup files *~ # vim backup files \#*\# # Coq annotation files *.glob # Coq auxiliary files .*.aux *.vos *.vok # Coq compilation unit *.vo *.annot *.cmo *.cma *.cmi *.a *.o *.cmi *.cmt *.cmti *.cmx *.cmxs *.cmxa # coqpp generated file src/abstraction.ml # lia cache .lia.cache paramcoq-1.1.3-coq8.19/.merlin000066400000000000000000000001551454026223400157110ustar00rootroot00000000000000FLG -rectypes -thread -w @1..50@59-4-44 S src B src PKG threads threads.posix coq.intf coq.ltac coq.idetop paramcoq-1.1.3-coq8.19/AUTHORS000066400000000000000000000002751454026223400154750ustar00rootroot00000000000000ParamCoq Copyright (c) 2012-2018 Chantal Keller (Inria, École polytechnique) Marc Lasson (ÉNS de Lyon) Abhishek Anand Pierre Roux Emilio Jesús Gallego Arias Cyril Cohen Matthieu Sozeau paramcoq-1.1.3-coq8.19/LICENSE000066400000000000000000000020421454026223400154240ustar00rootroot00000000000000ParamCoq Copyright (c) 2012-2018 Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. paramcoq-1.1.3-coq8.19/Makefile000066400000000000000000000005171454026223400160640ustar00rootroot00000000000000all: 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 paramcoq-1.1.3-coq8.19/README.md000066400000000000000000000112361454026223400157030ustar00rootroot00000000000000 # Paramcoq [![Docker CI][docker-action-shield]][docker-action-link] [![Contributing][contributing-shield]][contributing-link] [![Code of Conduct][conduct-shield]][conduct-link] [![Zulip][zulip-shield]][zulip-link] [![DOI][doi-shield]][doi-link] [docker-action-shield]: https://github.com/coq-community/paramcoq/actions/workflows/docker-action.yml/badge.svg?branch=v8.19 [docker-action-link]: https://github.com/coq-community/paramcoq/actions/workflows/docker-action.yml [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 [doi-shield]: https://zenodo.org/badge/DOI/10.4230/LIPIcs.CSL.2012.381.svg [doi-link]: https://doi.org/10.4230/LIPIcs.CSL.2012.381 A Coq plugin providing commands for generating parametricity statements. Typical applications of such statements are in data refinement proofs. Note that the plugin is still in an experimental state - it is not very user friendly (lack of good error messages) and still contains bugs. But it is usable enough to "translate" a large chunk of the standard library. ## Meta - Author(s): - Chantal Keller (initial) - Marc Lasson (initial) - Abhishek Anand - Pierre Roux - Emilio Jesús Gallego Arias - Cyril Cohen - Matthieu Sozeau - Coq-community maintainer(s): - Pierre Roux ([**@proux01**](https://github.com/proux01)) - License: [MIT License](LICENSE) - Compatible Coq versions: The v8.19 branch supports version 8.19 of Coq, see releases for compatibility with released versions of Coq - Additional dependencies: none - Coq namespace: `Param` - Related publication(s): - [Parametricity in an Impredicative Sort](https://hal.archives-ouvertes.fr/hal-00730913/) doi:[10.4230/LIPIcs.CSL.2012.381](https://doi.org/10.4230/LIPIcs.CSL.2012.381) ## Building and installation instructions The easiest way to install the latest released version of Paramcoq 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-paramcoq ``` To instead build and install manually, do: ``` shell git clone https://github.com/coq-community/paramcoq.git cd paramcoq make # or make -j make install ``` ## Usage and Commands To load the plugin and make its commands available: ```coq From Param Require Import Param. ``` The command scheme for named translations is: ``` Parametricity as [arity ]. ``` For example, the following command generates a translation named `my_param` of the constant or inductive `my_id` with arity 2 (the default): ```coq Parametricity my_id as my_param. ``` The command scheme for automatically named translations is: ```coq Parametricity [Recursive] [arity ] [qualified]. ``` Such commands generate and name translations based on the given identifier. The `Recursive` option can be used to recursively translate all the constants and inductives which are used by the constant or inductive with the given identifier. The `qualified` option allows you to use a qualified default name for the translated constants and inductives. The default name then has the form `Module_o_Submodule_o_my_id` if the identifier `my_id` is declared in the `Module.Submodule` namespace. Instead of using identifiers, you can provide explicit terms to translate, according to the following command scheme: ```coq Parametricity Translation [as ] [arity ]. ``` This defines a new constant containing the parametricity translation of the given term. To recursively translate everything in a module: ```coq Parametricity Module . ``` When translating terms containing section variables or axioms, it may be useful to declare a term to be the translation of a constant: ```coq Realizer [as ] [arity ] := . ``` Note that translating a term or module may lead to proof obligations (for some fixpoints and opaque terms if you did not import `ProofIrrelevence`). You need to declare a tactic to solve such proof obligations: ```coq Parametricity Tactic := . ``` (supports global/export/local attributes like Obligation Tactic) paramcoq-1.1.3-coq8.19/_CoqProject000066400000000000000000000003251454026223400165540ustar00rootroot00000000000000-generate-meta-for-package coq-paramcoq -R theories Param -R src Param -I src src/debug.ml src/parametricity.ml src/relations.ml src/declare_translation.ml src/abstraction.mlg src/paramcoq.mlpack theories/Param.v paramcoq-1.1.3-coq8.19/coq-paramcoq.opam000066400000000000000000000025271454026223400176700ustar00rootroot00000000000000# 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: "Pierre Roux " version: "8.19.dev" homepage: "https://github.com/coq-community/paramcoq" dev-repo: "git+https://github.com/coq-community/paramcoq.git" bug-reports: "https://github.com/coq-community/paramcoq/issues" license: "MIT" synopsis: "Plugin for generating parametricity statements to perform refinement proofs" description: """ A Coq plugin providing commands for generating parametricity statements. Typical applications of such statements are in data refinement proofs. Note that the plugin is still in an experimental state - it is not very user friendly (lack of good error messages) and still contains bugs. But it is usable enough to "translate" a large chunk of the standard library.""" build: [make "-j%{jobs}%"] install: [ [make "install"] [make "-C" "test-suite" "examples"] {with-test} ] depends: [ "coq" {>= "8.19" & < "8.20~"} ] tags: [ "category:Miscellaneous/Coq Extensions" "keyword:paramcoq" "keyword:parametricity" "keyword:OCaml modules" "logpath:Param" ] authors: [ "Chantal Keller" "Marc Lasson" "Abhishek Anand" "Pierre Roux" "Emilio Jesús Gallego Arias" "Cyril Cohen" "Matthieu Sozeau" ] paramcoq-1.1.3-coq8.19/dune-project000066400000000000000000000000601454026223400167370ustar00rootroot00000000000000(lang dune 2.5) (using coq 0.2) (name paramcoq) paramcoq-1.1.3-coq8.19/meta.yml000066400000000000000000000070621454026223400160770ustar00rootroot00000000000000--- fullname: Paramcoq shortname: paramcoq organization: coq-community community: true action: true plugin: true doi: 10.4230/LIPIcs.CSL.2012.381 branch: 'v8.19' synopsis: Plugin for generating parametricity statements to perform refinement proofs description: |- A Coq plugin providing commands for generating parametricity statements. Typical applications of such statements are in data refinement proofs. Note that the plugin is still in an experimental state - it is not very user friendly (lack of good error messages) and still contains bugs. But it is usable enough to "translate" a large chunk of the standard library. publications: - pub_title: Parametricity in an Impredicative Sort pub_url: https://hal.archives-ouvertes.fr/hal-00730913/ pub_doi: 10.4230/LIPIcs.CSL.2012.381 authors: - name: Chantal Keller initial: true - name: Marc Lasson initial: true - name: Abhishek Anand - name: Pierre Roux - name: Emilio Jesús Gallego Arias - name: Cyril Cohen - name: Matthieu Sozeau maintainers: - name: Pierre Roux nickname: proux01 license: fullname: MIT License identifier: MIT supported_coq_versions: text: >- The v8.19 branch supports version 8.19 of Coq, see releases for compatibility with released versions of Coq opam: '{>= "8.19" & < "8.20~"}' categories: - name: 'Miscellaneous/Coq Extensions' keywords: - name: paramcoq - name: parametricity - name: OCaml modules namespace: Param opam-file-maintainer: 'Pierre Roux ' opam-file-version: '8.19.dev' tested_coq_opam_versions: - version: '8.19' documentation: |- ## Usage and Commands To load the plugin and make its commands available: ```coq From Param Require Import Param. ``` The command scheme for named translations is: ``` Parametricity as [arity ]. ``` For example, the following command generates a translation named `my_param` of the constant or inductive `my_id` with arity 2 (the default): ```coq Parametricity my_id as my_param. ``` The command scheme for automatically named translations is: ```coq Parametricity [Recursive] [arity ] [qualified]. ``` Such commands generate and name translations based on the given identifier. The `Recursive` option can be used to recursively translate all the constants and inductives which are used by the constant or inductive with the given identifier. The `qualified` option allows you to use a qualified default name for the translated constants and inductives. The default name then has the form `Module_o_Submodule_o_my_id` if the identifier `my_id` is declared in the `Module.Submodule` namespace. Instead of using identifiers, you can provide explicit terms to translate, according to the following command scheme: ```coq Parametricity Translation [as ] [arity ]. ``` This defines a new constant containing the parametricity translation of the given term. To recursively translate everything in a module: ```coq Parametricity Module . ``` When translating terms containing section variables or axioms, it may be useful to declare a term to be the translation of a constant: ```coq Realizer [as ] [arity ] := . ``` Note that translating a term or module may lead to proof obligations (for some fixpoints and opaque terms if you did not import `ProofIrrelevence`). You need to declare a tactic to solve such proof obligations: ```coq Parametricity Tactic := . ``` (supports global/export/local attributes like Obligation Tactic) --- paramcoq-1.1.3-coq8.19/src/000077500000000000000000000000001454026223400152105ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/src/abstraction.mlg000066400000000000000000000117401454026223400202250ustar00rootroot00000000000000{ (**************************************************************************) (* *) (* ParamCoq *) (* Copyright (C) 2012 - 2018 *) (* *) (* See the AUTHORS file for the list of contributors *) (* *) (* This file is distributed under the terms of the MIT License *) (* *) (**************************************************************************) } DECLARE PLUGIN "coq-paramcoq.plugin" { open Ltac_plugin open Feedback open Stdarg open Tacarg open Parametricity open Declare_translation } VERNAC COMMAND EXTEND SetParametricityTactic CLASSIFIED AS SIDEFF | #[ locality = Tactic_option.tac_option_locality; ] [ "Parametricity" "Tactic" ":=" tactic(t) ] -> { Relations.set_parametricity_tactic locality (Tacintern.glob_tactic t) } END VERNAC COMMAND EXTEND ShowTable CLASSIFIED AS QUERY | [ "Show" "Parametricity" "Table" ] -> { Relations.print_relations () } END VERNAC COMMAND EXTEND ShowParametricityTactic CLASSIFIED AS QUERY | [ "Show" "Parametricity" "Tactic" ] -> { Pp.(msg_info (str "Paramericity obligation tactic is " ++ Relations.print_parametricity_tactic ())) } END VERNAC COMMAND EXTEND ParametricityDefined CLASSIFIED AS SIDEFF STATE program | ![ close_proof ] [ "Parametricity" "Done" ] -> { parametricity_close_proof } END VERNAC COMMAND EXTEND AbstractionReference CLASSIFIED AS SIDEFF | [ "Parametricity" ref(c) ] -> { command_reference default_arity (intern_reference_to_name c) None } | [ "Parametricity" reference(c) "as" ident(name)] -> { command_reference default_arity (intern_reference_to_name c) (Some name) } | [ "Parametricity" reference(c) "qualified" ] -> { command_reference ~fullname:true default_arity (intern_reference_to_name c) None } | [ "Parametricity" reference(c) "arity" int(arity) ] -> { command_reference arity (intern_reference_to_name c) None } | [ "Parametricity" reference(c) "arity" int(arity) "as" ident(name) ] -> { command_reference arity (intern_reference_to_name c) (Some name) } | [ "Parametricity" reference(c) "arity" int(arity) "qualified" ] -> { command_reference ~fullname:true arity (intern_reference_to_name c) None } | [ "Parametricity" reference(c) "as" ident(name) "arity" integer(arity) ] -> { command_reference arity (intern_reference_to_name c) (Some name) } END VERNAC COMMAND EXTEND AbstractionRecursive CLASSIFIED AS SIDEFF | [ "Parametricity" "Recursive" reference(c) ] -> { command_reference_recursive default_arity (intern_reference_to_name c) } | [ "Parametricity" "Recursive" reference(c) "arity" integer(arity) ] -> { command_reference_recursive arity (intern_reference_to_name c) } | [ "Parametricity" "Recursive" reference(c) "qualified" ] -> { command_reference_recursive ~fullname:true default_arity (intern_reference_to_name c) } | [ "Parametricity" "Recursive" reference(c) "arity" integer(arity) "qualified" ] -> { command_reference_recursive ~fullname:true arity (intern_reference_to_name c) } END VERNAC COMMAND EXTEND Abstraction CLASSIFIED AS SIDEFF | [ "Parametricity" "Translation" constr(c) "as" ident(name)] -> { translate_command default_arity c name } | [ "Parametricity" "Translation" constr(c) "as" ident(name) "arity" integer(arity) ] -> { translate_command arity c name } | [ "Parametricity" "Translation" constr(c) "arity" integer(arity) "as" ident(name)] -> { translate_command arity c name } END VERNAC COMMAND EXTEND TranslateModule CLASSIFIED AS SIDEFF | [ "Parametricity" "Module" global(qid) ] -> { ignore (translate_module_command Parametricity.default_arity qid) } | [ "Parametricity" "Module" global(qid) "as" ident(name) ] -> { ignore (translate_module_command ~name Parametricity.default_arity qid) } | [ "Parametricity" "Module" global(qid) "arity" integer(arity) ] -> { ignore (translate_module_command arity qid) } | [ "Parametricity" "Module" global(qid) "as" ident(name) "arity" integer(arity) ] -> { ignore (translate_module_command ~name arity qid) } | [ "Parametricity" "Module" global(qid) "arity" integer(arity) "as" ident(name)] -> { ignore (translate_module_command ~name arity qid) } END VERNAC COMMAND EXTEND Realizer CLASSIFIED AS SIDEFF | [ "Realizer" constr(c) "as" ident(name) ":=" constr(t) ] -> { realizer_command Parametricity.default_arity (Some name) c t } | [ "Realizer" constr(c) "as" ident(name) "arity" integer(arity) ":=" constr(t) ] -> { realizer_command arity (Some name) c t } | [ "Realizer" constr(c) "arity" integer(arity) "as" ident(name) ":=" constr(t) ] -> { realizer_command arity (Some name) c t } END paramcoq-1.1.3-coq8.19/src/debug.ml000066400000000000000000000245541454026223400166420ustar00rootroot00000000000000(**************************************************************************) (* *) (* ParamCoq *) (* Copyright (C) 2012 - 2018 *) (* *) (* See the AUTHORS file for the list of contributors *) (* *) (* This file is distributed under the terms of the MIT License *) (* *) (**************************************************************************) open Names open EConstr open Pp let toCDecl old : (Constr.constr, Constr.constr) Context.Rel.Declaration.pt = let (name,value,typ) = old in match value with | Some value -> Context.Rel.Declaration.LocalDef (name,value,typ) | None -> Context.Rel.Declaration.LocalAssum (name,typ) let toDecl old : rel_declaration = let (name,value,typ) = old in match value with | Some value -> Context.Rel.Declaration.LocalDef (name,value,typ) | None -> Context.Rel.Declaration.LocalAssum (name,typ) let fromDecl (n: ('a, 'b) Context.Rel.Declaration.pt) = match n with | Context.Rel.Declaration.LocalDef (name,value,typ) -> (name,Some value,typ) | Context.Rel.Declaration.LocalAssum (name,typ) -> (name,None,typ) (* let fromFromLocalEntry (l: Entries.local_entry): Constr.constr = match l with | Entries.LocalDefEntry c -> c | Entries.LocalAssumEntry c -> c *) let all = [`ProofIrrelevance; `Abstraction; `Relation; `Translate; `Fix; `Case; `GenericUnfolding; `Unfolding; `Inductive; `Module; `Realizer; `Opacity] let debug_flag = [`Time; `Fix; `Module; `Abstraction; `Realizer; `Translate; `Cast; `Inductive; `Module; `ProofIrrelevance] let debug_mode = ref false let set_debug_mode = Goptions.declare_bool_option { Goptions.optdepr = None; Goptions.optstage = Interp; Goptions.optkey = ["Parametricity"; "Debug"]; Goptions.optread = (fun () -> !debug_mode); Goptions.optwrite = (:=) debug_mode } let debug_rename_env env evd = let rc = EConstr.rel_context env in let env = Environ.reset_context env in let rc = Namegen.name_context env evd rc in let env = push_rel_context rc env in Namegen.make_all_name_different env evd let debug_message flags s e = if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then Feedback.msg_notice Pp.(str s ++ e) let debug_env flags (s : string) env evd = if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then let env = debug_rename_env env evd in Feedback.(msg_notice (Pp.str s ++ Printer.pr_context_of env evd)) let debug flags (s : string) env evd c = if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then try let env = debug_rename_env env evd in Feedback.(msg_notice (Pp.str s ++ Printer.pr_context_of env evd)); Feedback.(msg_notice (Pp.str "" ++ Pp.str "\n |-" ++ Printer.pr_econstr_env env evd c)) with e -> Feedback.(msg_notice (str (Printf.sprintf "Caught exception while debugging '%s'" (Printexc.to_string e)))) let debug_evar_map flags s env evd = if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then ( Feedback.msg_info Pp.(str s ++ Termops.pr_evar_map ~with_univs:true None env evd)) let debug_string flags s = if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then Feedback.msg_notice (Pp.str ("--->\t"^s)) let debug_case_info flags ci = let open Constr in if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then let (ind, k) = ci.ci_ind in let ind_string = Printf.sprintf "%s[%d]" (MutInd.to_string ind) k in let param = ci.ci_npar in let ndecls = String.concat ";" (List.map string_of_int (Array.to_list ci.ci_cstr_ndecls)) in let nargs = String.concat ";" (List.map string_of_int (Array.to_list ci.ci_cstr_nargs)) in let pp_info x = let ind_tags = String.concat ";" (List.map string_of_bool x.ind_tags) in let cstr_tags = String.concat "," (List.map (fun tags -> String.concat ";" (List.map string_of_bool tags)) (Array.to_list x.cstr_tags)) in let string_of_style = match x.style with LetStyle -> "LetStyle" | IfStyle -> "IfStyle" | LetPatternStyle -> "LetPatternStyle" | MatchStyle -> "MatchStyle" | RegularStyle -> "RegularStyle" in Printf.sprintf "ind_tags = %s, cstr_tags = %s, style = %s" ind_tags cstr_tags string_of_style in debug_string flags (Printf.sprintf "CASEINFO:inductive = %s.\nparam = %d.\nndecls = %s.\nnargs = %s.\npp_info = %s\n.EOFCASEINFO" ind_string param ndecls nargs (pp_info ci.ci_pp_info)) let debug_rel_context flags s env l = if !debug_mode && List.exists (fun x -> List.mem x flags) debug_flag then Feedback.msg_notice Pp.(str s ++ (Termops.Internal.print_rel_context (push_rel_context l env))) let not_implemented ?(reason = "no reason") env evd t = debug [`Not_implemented] (Printf.sprintf "not implemented (%s):" reason) env evd t; failwith "not_implemented" module SortSet = Set.Make(Sorts) let rec sorts accu t = match Constr.kind t with | Constr.Sort t -> SortSet.add t accu | _ -> Constr.fold sorts accu t let debug_mutual_inductive_entry = let open Entries in let open Pp in let field name value cont = (align ()) ++ (str name) ++ (str " : ") ++ value ++ fnl () ++ cont in let rec debug_mutual_inductive_entry evd entry = let mind_entry_record_pp = str (match entry.mind_entry_record with | Some (Some id) -> let s = ref "" in let first = ref true in for i = 0 to Array.length id - 1 do if not !first then s := !s ^ ", " else first := false; s := !s ^ Id.to_string id.(i) done; Printf.sprintf "Some (Some %s)" !s | Some None -> "Some None" | None -> "None") in let mind_entry_finite_pp = let open Declarations in str (match entry.mind_entry_finite with Finite -> "Finite" | CoFinite -> "CoFinite" | BiFinite -> "BiFinite") in debug_string all "env_params:" ; let env_params = List.fold_left (fun acc decl -> debug_env all "acc = " acc evd; match decl with | Context.Rel.Declaration.LocalAssum (id, typ) -> debug all "typ = " acc evd (of_constr typ); Environ.push_rel decl acc | Context.Rel.Declaration.LocalDef (id, def, typ) -> debug all "def = " acc evd (of_constr def); debug all "typ = " acc evd (of_constr typ); Environ.push_rel decl acc) (Global.env ()) (List.rev entry.mind_entry_params) in debug_string all "arities:"; let mind_entry_params_pp = Printer.pr_context_of env_params Evd.empty in let arities = List.map (fun entry -> entry.mind_entry_typename, entry.mind_entry_arity) entry.mind_entry_inds in let mind_entry_inds_pp = List.fold_left app (str "") (List.map (pp_one_inductive_entry arities env_params) entry.mind_entry_inds) in let mind_entry_polymorphic_pp = str (match entry.mind_entry_universes with | Monomorphic_ind_entry | Template_ind_entry _ -> "false" | Polymorphic_ind_entry _ -> "true" ) in let mind_entry_universes_pp = match entry.mind_entry_universes with | Monomorphic_ind_entry | Template_ind_entry _ -> mt () | Polymorphic_ind_entry ux -> UVars.pr_universe_context Sorts.QVar.raw_pr UnivNames.pr_level_with_global_universes ux in let mind_entry_cumul_pp = bool (Option.has_some entry.mind_entry_variance) in let mind_entry_private_pp = match entry.mind_entry_private with None -> str "None" | Some true -> str "Some true" | Some false -> str "Some false" in let fields = List.rev [ "mind_entry_record", mind_entry_record_pp; "mind_entry_finite", mind_entry_finite_pp; "mind_entry_params", mind_entry_params_pp; "mind_entry_inds", mind_entry_inds_pp; "mind_entry_polymorphic", mind_entry_polymorphic_pp; "mind_entry_universes", mind_entry_universes_pp; "mind_entry_cumulative", mind_entry_cumul_pp; "mind_entry_private", mind_entry_private_pp] in let res = (str "{") ++ hov 140 ( List.fold_left (fun acc (name, pp) -> field name pp acc) (mt ()) fields) ++ str "}" in Feedback.msg_notice res; let sorts = List.fold_left (fun accu ind -> sorts accu ind.mind_entry_arity) SortSet.empty entry.mind_entry_inds in let sorts_pp = SortSet.fold (fun sort accu -> accu ++ (Printer.pr_sort evd sort) ++ fnl ()) sorts (mt ()) in Feedback.msg_notice (hov 100 sorts_pp) and pp_one_inductive_entry arities env_params entry = let params = Environ.rel_context env_params in let arities = List.map (fun (x, y) -> (x, Term.it_mkProd_or_LetIn y params)) arities in let arities_params_env = let env_arities = List.fold_left (fun acc (id, arity) -> Environ.push_rel (toCDecl (Context.make_annot (Name id) Sorts.Relevant, None, arity)) acc) Environ.empty_env (List.rev arities) in Environ.push_rel_context params env_arities in let mind_entry_typename_pp = str (Id.to_string entry.mind_entry_typename) in let mind_entry_arity_pp = Printer.safe_pr_constr_env env_params Evd.empty entry.mind_entry_arity in let mind_entry_consnames_pp = str (String.concat ";" (List.map Id.to_string entry.mind_entry_consnames)) in let mind_entry_lc_pp = List.fold_left app (str "") (List.map (Printer.safe_pr_constr_env arities_params_env Evd.empty) entry.mind_entry_lc) in let fields = [ "mind_entry_typename", mind_entry_typename_pp; "mind_entry_arity", mind_entry_arity_pp; "mind_entry_consnames", mind_entry_consnames_pp; "mind_entry_lc", mind_entry_lc_pp ] in str "{" ++ hov 100 ( List.fold_left (fun acc (name, pp) -> field name pp acc) (mt ()) fields) ++ str "}" in fun evd entry -> if !debug_mode then debug_mutual_inductive_entry evd entry paramcoq-1.1.3-coq8.19/src/declare_translation.ml000066400000000000000000000473601454026223400215710ustar00rootroot00000000000000(**************************************************************************) (* *) (* ParamCoq *) (* Copyright (C) 2012 - 2018 *) (* *) (* See the AUTHORS file for the list of contributors *) (* *) (* This file is distributed under the terms of the MIT License *) (* *) (**************************************************************************) open Feedback open Libnames open EConstr open Debug open Parametricity [@@@ocaml.warning "-40"] let error = CErrors.user_err let ongoing_translation = Summary.ref false ~name:"parametricity ongoing translation" let ongoing_translation_opacity = Summary.ref false ~name:"parametricity ongoing translation opacity" let check_nothing_ongoing () = if !ongoing_translation then error (Pp.str "Some terms are being translated, please prove pending obligations before starting a new one. End them with the command 'Parametricity Done'.") let intern_reference_to_name qualid = match Constrintern.intern_reference qualid with | Some x -> x | None -> error Pp.(Libnames.pr_qualid qualid ++ str " does not refer to a global constant") let obligation_message () = let open Pp in msg_notice (str "The parametricity tactic generated generated proof obligations. " ++ str "Please prove them and end your proof with 'Parametricity Done'. ") let default_continuation = ignore let parametricity_close_proof ~lemma ~pm = let opaque = if !ongoing_translation_opacity then Vernacexpr.Opaque else Transparent in ongoing_translation := false; let pm, _ = Declare.Proof.save ~pm ~proof:lemma ~opaque ~idopt:None in pm let add_definition ~opaque ~hook ~poly ~scope ~kind ~tactic name env evd term typ = debug Debug.all "add_definition, term = " env evd (snd (term ( evd))); debug Debug.all "add_definition, typ = " env evd typ; debug_evar_map Debug.all "add_definition, evd = " env evd; let init_tac = let open Proofview in let typecheck = true in tclTHEN (Refine.refine ~typecheck begin fun sigma -> term sigma end) tactic in ongoing_translation_opacity := opaque; let info = Declare.Info.make ~hook ~scope ~kind ~poly () in let cinfo = Declare.CInfo.make ~name ~typ () in let lemma = Declare.Proof.start ~cinfo ~info evd in let lemma = Declare.Proof.map lemma ~f:(fun p -> let p, _, () = Proof.run_tactic Global.(env()) init_tac p in p) in let proof = Declare.Proof.get lemma in let is_done = Proof.is_done proof in if is_done then (let pm = Declare.OblState.empty in let _pm = parametricity_close_proof ~pm ~lemma in None) else begin ongoing_translation := true; obligation_message (); Some lemma end let declare_abstraction ?(opaque = false) ?(continuation = default_continuation) ~poly ~scope ~kind arity evdr env a name = Debug.debug_evar_map Debug.all "declare_abstraction, evd = " env !evdr; debug [`Abstraction] "declare_abstraction, a =" env !evdr a; let b = Retyping.get_type_of env !evdr a in debug [`Abstraction] "declare_abstraction, b =" env !evdr b; let b = Retyping.get_type_of env !evdr a in let b_R = relation arity evdr env b in let sub = range (fun k -> prime !evdr arity k a) arity in let b_R = EConstr.Vars.substl sub b_R in let a_R = fun evd -> let evdr = ref evd in let a_R = translate arity evdr env a in debug [`Abstraction] "a_R = " env !evdr a_R; debug_evar_map Debug.all "abstraction, evar_map = " env !evdr; !evdr, a_R in let evd = !evdr in let hook = match EConstr.kind !evdr a with | Const cte when let cte = (fst cte, EInstance.kind !evdr (snd cte)) in (try ignore (Relations.get_constant arity (UVars.out_punivs cte)); false with Not_found -> true) -> Declare.Hook.(make (fun { dref ; _ } -> if !ongoing_translation then error (Pp.str "Please use the 'Debug.Done' command to end proof obligations generated by the parametricity tactic."); Pp.(Flags.if_verbose msg_info (str (Printf.sprintf "'%s' is now a registered translation." (Names.Id.to_string name)))); let cte = (fst cte, EInstance.kind !evdr (snd cte)) in Relations.declare_relation arity (Names.GlobRef.ConstRef (UVars.out_punivs cte)) dref; continuation ())) | _ -> Declare.Hook.(make (fun _ -> continuation ())) in let tactic = Relations.get_parametricity_tactic () in add_definition ~tactic ~opaque ~poly ~scope ~kind ~hook name env evd a_R b_R let declare_inductive name ?(continuation = default_continuation) arity evd env (((mut_ind, _) as ind, inst)) = let mut_body, _ = Inductive.lookup_mind_specif env ind in debug_string [`Inductive] "Translating mind body ..."; let translation_entry = Parametricity.translate_mind_body name arity evd env mut_ind mut_body inst in debug_string [`Inductive] ("Translating mind body ... done."); debug_evar_map [`Inductive] "evar_map inductive " env !evd; let size = Declarations.(Array.length mut_body.mind_packets) in let mut_ind_R = DeclareInd.declare_mutual_inductive_with_eliminations translation_entry (Monomorphic_entry Univ.ContextSet.empty, UnivNames.empty_binders) [] in for k = 0 to size-1 do Relations.declare_inductive_relation arity (mut_ind, k) (mut_ind_R, k) done; continuation () let translate_inductive_command arity c name = let env = Global.env () in let sigma = Evd.from_env env in let (sigma, c) = Constrintern.interp_open_constr env sigma c in let (ind, _) as pind, _ = try Inductive.find_rectype env (to_constr sigma c) with Not_found -> error (Pp.(str "Unable to locate an inductive in " ++ Printer.pr_econstr_env env sigma c)) in try let ind_R = Globnames.destIndRef (Relations.get_inductive arity ind) in error (Pp.(str "The inductive " ++ Printer.pr_inductive env ind ++ str " already as the following registered translation " ++ Printer.pr_inductive env ind_R)) with Not_found -> let evd = ref sigma in declare_inductive name arity evd env pind let declare_realizer ?(continuation = default_continuation) ?kind ?real arity evd env name (var : constr) = let gref = (match EConstr.kind !evd var with | Var id -> Names.GlobRef.VarRef id | Const (cst, _) -> Names.GlobRef.ConstRef cst | _ -> error (Pp.str "Realizer works only for variables and constants.")) in let evd', typ = Typing.type_of env !evd var in evd := evd'; let typ_R = Parametricity.relation arity evd env typ in let sub = range (fun _ -> var) arity in let typ_R = Vars.substl sub typ_R in let cpt = ref 0 in let real = incr cpt; match real with Some real -> fun sigma -> let (sigma, term) = real sigma in let realtyp = Retyping.get_type_of env sigma term in debug [`Realizer] (Printf.sprintf "real in realdef (%d) =" !cpt) env sigma term; debug [`Realizer] (Printf.sprintf "realtyp in realdef (%d) =" !cpt) env sigma realtyp; let sigma = Evarconv.unify_leq_delay env sigma realtyp typ_R in debug [`Realizer] (Printf.sprintf "real in realdef (%d), after =" !cpt) env sigma term; debug [`Realizer] (Printf.sprintf "realtyp in realdef (%d), after =" !cpt) env sigma realtyp; (sigma, term) | None -> fun sigma -> (let sigma, real = new_evar_compat env sigma typ_R in (sigma, real)) in let scope = Locality.(Global ImportDefaultBehavior) in let poly = true in let kind = Decls.(IsDefinition Definition) in let name = match name with Some x -> x | _ -> let name_str = (match EConstr.kind !evd var with | Var id -> Names.Id.to_string id | Const (cst, _) -> Names.Label.to_string (Names.Constant.label cst) | _ -> assert false) in let name_R = translate_string arity name_str in Names.Id.of_string name_R in let sigma = !evd in debug_evar_map [`Realizer] "ear_map =" env sigma; let hook = Declare.Hook.(make (fun { dref; _ } -> Pp.(msg_info (str (Printf.sprintf "'%s' is now a registered translation." (Names.Id.to_string name)))); Relations.declare_relation arity gref dref; continuation ())) in let tactic = Relations.get_parametricity_tactic () in add_definition ~tactic ~opaque:false ~poly ~scope ~kind ~hook name env sigma real typ_R let realizer_command arity name var real = let env = Global.env () in let sigma = Evd.from_env env in let (sigma, var) = Constrintern.interp_open_constr env sigma var in RetrieveObl.check_evars env sigma; let real = fun sigma -> Constrintern.interp_open_constr env sigma real in ignore(declare_realizer arity (ref sigma) env name var ~real) let rec list_continuation final f l _ = match l with [] -> final () | hd::tl -> f (list_continuation final f tl) hd let rec translate_module_command ?name arity r = check_nothing_ongoing (); let qid = r in let mb = try Global.lookup_module (Nametab.locate_module qid) with Not_found -> error Pp.(str "Unknown Module " ++ pr_qualid qid) in declare_module ?name arity mb and id_of_module_path mp = let open Names in let open ModPath in match mp with | MPdot (_, lab) -> Label.to_id lab | MPfile dp -> List.hd (DirPath.repr dp) | MPbound id -> MBId.to_id id and declare_module ?(continuation = ignore) ?name arity mb = debug_string [`Module] "--> declare_module"; let open Declarations in let mp = mb.mod_mp in match mb.mod_expr, mb.mod_type with | Algebraic _, NoFunctor fields | FullStruct, NoFunctor fields -> let id = id_of_module_path mp in let id_R = match name with Some id -> id | None -> translate_id arity id in debug_string [`Module] (Printf.sprintf "start module: '%s' (translating '%s')." (Names.Id.to_string id_R) (Names.Id.to_string id)); let _mp_R = Declaremods.start_module None id_R [] (Declaremods.Check []) in list_continuation (fun _ -> debug_string [`Module] (Printf.sprintf "end module: '%s'." (Names.Id.to_string id_R)); ignore (Declaremods.end_module ()); continuation ()) (fun continuation -> function | (lab, SFBconst cb) when (match cb.const_body with OpaqueDef _ -> false | Undef _ -> true | _ -> false) -> let cst = Mod_subst.constant_of_delta_kn mb.mod_delta (Names.KerName.make mp lab) in if try ignore (Relations.get_constant arity cst); true with Not_found -> false then continuation () else debug_string [`Module] (Printf.sprintf "axiom field: '%s'." (Names.Label.to_string lab)); (* As we rely on globally declared constants we need to access the global env here; previously indeed there was a bug in the call to Pfedit.get_current_context [it worked because we had no proof state] *) let env = Global.env () in let evd = Evd.from_env env in let evd, ucst = Evd.(with_sort_context_set univ_rigid evd (UnivGen.fresh_constant_instance env cst)) in let evdr = ref evd in ignore(declare_realizer ~continuation arity evdr env None (mkConstU (fst ucst, EInstance.make (snd ucst)))) | (lab, SFBconst cb) -> let opaque = match cb.const_body with OpaqueDef _ -> true | _ -> false in let poly = Declareops.constant_is_polymorphic cb in let scope = Locality.(Global ImportDefaultBehavior) in let kind = Decls.(IsDefinition Definition) in let cst = Mod_subst.constant_of_delta_kn mb.mod_delta (Names.KerName.make mp lab) in if try ignore (Relations.get_constant arity cst); true with Not_found -> false then continuation () else let env = Global.env () in let evd = Evd.from_env env in let evd, ucst = Evd.(with_sort_context_set univ_rigid evd (UnivGen.fresh_constant_instance env cst)) in let c = mkConstU (fst ucst, EInstance.make (snd ucst)) in let evdr = ref evd in let lab_R = translate_id arity (Names.Label.to_id lab) in debug [`Module] "field : " env !evdr c; (try let evd, typ = Typing.type_of env !evdr c in evdr := evd; debug [`Module] "type :" env !evdr typ with e -> error (Pp.str (Printexc.to_string e))); debug_string [`Module] (Printf.sprintf "constant field: '%s'." (Names.Label.to_string lab)); ignore(declare_abstraction ~opaque ~continuation ~poly ~scope ~kind arity evdr env c lab_R) | (lab, SFBmind _) -> let env = Global.env () in let evd = Evd.from_env env in let evdr = ref evd in let mut_ind = Mod_subst.mind_of_delta_kn mb.mod_delta (Names.KerName.make mp lab) in let ind = (mut_ind, 0) in if try ignore (Relations.get_inductive arity ind); true with Not_found -> false then continuation () else begin let evd, pind = Evd.(with_sort_context_set univ_rigid !evdr (UnivGen.fresh_inductive_instance env ind)) in evdr := evd; debug_string [`Module] (Printf.sprintf "inductive field: '%s'." (Names.Label.to_string lab)); let ind_name = Names.Id.of_string @@ translate_string arity @@ Names.Label.to_string @@ Names.MutInd.label @@ mut_ind in declare_inductive ind_name ~continuation arity evdr env pind end | (lab, SFBmodule mb') when match mb'.mod_type with NoFunctor _ -> (match mb'.mod_expr with FullStruct | Algebraic _ -> true | _ -> false) | _ -> false -> declare_module ~continuation arity mb' | (lab, _) -> Pp.(Flags.if_verbose msg_info (str (Printf.sprintf "Ignoring field '%s'." (Names.Label.to_string lab)))); continuation () ) fields () | Struct _, _ -> error Pp.(str "Module " ++ (str (Names.ModPath.to_string mp)) ++ str " is an interactive module.") | Abstract, _ -> error Pp.(str "Module " ++ (str (Names.ModPath.to_string mp)) ++ str " is an abstract module.") | _ -> Feedback.msg_warning Pp.(str "Module " ++ (str (Names.ModPath.to_string mp)) ++ str " is not a fully-instantiated module."); continuation () let command_variable ?(continuation = default_continuation) arity variable names = error (Pp.str "Cannot translate an axiom nor a variable. Please use the 'Parametricity Realizer' command.") let translateFullName ~fullname arity (kername : Names.KerName.t) : string = let nstr = (translate_string arity @@ Names.Label.to_string @@ Names.KerName.label @@ kername)in let pstr = (Names.ModPath.to_string @@ Names.KerName.modpath @@ kername) in let plstr = Str.split (Str.regexp ("\\.")) pstr in if fullname then (String.concat "_o_" (plstr@[nstr])) else nstr let command_constant ?(continuation = default_continuation) ~fullname arity constant names = let env = Global.env () in let evd = Evd.from_env env in let poly, opaque = let cb = Global.lookup_constant constant in let open Declarations in Declareops.constant_is_polymorphic cb, (match cb.const_body with Def _ -> false | _ -> true) in let name = match names with | None -> Names.Id.of_string @@ translateFullName ~fullname arity @@ Names.Constant.canonical @@ constant | Some name -> name in let scope = Locality.(Global ImportDefaultBehavior) in let kind = Decls.(IsDefinition Definition) in let evd, pconst = Evd.(with_sort_context_set univ_rigid evd (UnivGen.fresh_constant_instance env constant)) in let constr = mkConstU (fst pconst, EInstance.make @@ snd pconst) in declare_abstraction ~continuation ~opaque ~poly ~scope ~kind arity (ref evd) env constr name let command_inductive ?(continuation = default_continuation) ~fullname arity inductive names = let env = Global.env () in let evd = Evd.from_env env in let evd, pind = Evd.(with_sort_context_set univ_rigid evd (UnivGen.fresh_inductive_instance env inductive)) in let name = match names with | None -> Names.Id.of_string @@ translateFullName ~fullname arity @@ Names.MutInd.canonical @@ fst @@ fst @@ pind | Some name -> name in declare_inductive name ~continuation arity (ref evd) env pind let command_constructor ?(continuation = default_continuation) arity gref names = let open Pp in error ((str "'") ++ (Printer.pr_global gref) ++ (str "' is a constructor. To generate its parametric translation, please translate its inductive first.")) let command_reference ?(continuation = default_continuation) ?(fullname = false) arity gref names = check_nothing_ongoing (); let open Names.GlobRef in (* We ignore proofs for now *) let _pstate = match gref with | VarRef variable -> command_variable ~continuation arity variable names | ConstRef constant -> command_constant ~continuation ~fullname arity constant names | IndRef inductive -> command_inductive ~continuation ~fullname arity inductive names; None | ConstructRef constructor -> command_constructor ~continuation arity gref names in () let command_reference_recursive ?(continuation = default_continuation) ?(fullname = false) arity gref = let gref= Globnames.canonical_gr gref in let label = Names.Label.of_id (Nametab.basename_of_global gref) in (* Assumptions doesn't care about the universes *) let c, _ = UnivGen.fresh_global_instance (Global.env()) gref in let (direct, graph, _) = Assumptions.traverse label c in let inductive_of_constructor ref = let open Globnames in let ref= Globnames.canonical_gr ref in if not (isConstructRef ref) then ref else let (ind, _) = Globnames.destConstructRef ref in Names.GlobRef.IndRef ind in let rec fold_sort graph visited nexts f acc = Names.GlobRef.Set_env.fold (fun ref ((visited, acc) as visacc) -> let ref_ind = inductive_of_constructor ref in if Names.GlobRef.Set_env.mem ref_ind visited || Relations.is_referenced arity ref_ind then visacc else let nexts = Names.GlobRef.Map_env.find ref graph in let nexts = Option.default Names.GlobRef.Set_env.empty nexts in let visited = Names.GlobRef.Set_env.add ref_ind visited in let visited, acc = fold_sort graph visited nexts f acc in let acc = f ref_ind acc in (visited, acc) ) nexts (visited, acc) in let _, dep_refs = fold_sort graph Names.GlobRef.Set_env.empty direct (fun x l -> (inductive_of_constructor x)::l) [] in let dep_refs = List.rev dep_refs in (* DEBUG: *) (* Pp.(msg_info (str "DepRefs:")); * List.iter (fun x -> msg_info (Printer.pr_global x)) dep_refs; *) list_continuation continuation (fun continuation gref -> command_reference ~continuation ~fullname arity gref None) dep_refs () let translate_command arity c name = if !ongoing_translation then error (Pp.str "On going translation."); (* Same comment as above *) let env = Global.env () in let evd = Evd.from_env env in let (evd, c) = Constrintern.interp_open_constr env evd c in let cte_option = match kind evd c with Const cte -> Some cte | _ -> None in let poly, opaque = match cte_option with | Some (cte, _) -> let cb = Global.lookup_constant cte in Declarations.((* cb.const_polymorphic, *) false, match cb.const_body with Def _ -> false | _ -> true) | None -> false, false in let scope = Locality.(Global ImportDefaultBehavior) in let kind = Decls.(IsDefinition Definition) in let _ : Declare.Proof.t option = declare_abstraction ~opaque ~poly ~scope ~kind arity (ref evd) env c name in () paramcoq-1.1.3-coq8.19/src/dune000066400000000000000000000004011454026223400160610ustar00rootroot00000000000000(library (name paramcoq) (public_name coq-paramcoq.plugin) (synopsis "Plugin for generating parametricity statements to perform refinement proofs") (flags :standard -rectypes -w -9-27) (libraries coq-core.plugins.ltac)) (coq.pp (modules abstraction)) paramcoq-1.1.3-coq8.19/src/paramcoq.mlpack000066400000000000000000000001131454026223400201770ustar00rootroot00000000000000Debug Relations Parametricity Declare_translation Abstraction Paramcoq_mod paramcoq-1.1.3-coq8.19/src/parametricity.ml000066400000000000000000001506061454026223400204270ustar00rootroot00000000000000(**************************************************************************) (* *) (* ParamCoq *) (* Copyright (C) 2012 - 2018 *) (* *) (* See the AUTHORS file for the list of contributors *) (* *) (* This file is distributed under the terms of the MIT License *) (* *) (**************************************************************************) module CVars = Vars open Util open Names open Environ open EConstr open Vars open Debug [@@@ocaml.warning "-40"] let mkannot = Context.make_annot let error msg = CErrors.user_err msg let new_evar_compat env evd uf_opaque_stmt = Evarutil.new_evar env evd uf_opaque_stmt module CoqConstants = struct let msg = "parametricity: unable to fetch constants" let add_constraints evdref univ = let env = Global.env () in let extract_type_sort poly_ref = let evd, poly_ref = Evd.fresh_global (Global.env ()) !evdref poly_ref in evdref := evd; let ref_type = Retyping.get_type_of env !evdref poly_ref in let ref_sort = let _, a, _ = destProd !evdref ref_type in a in evdref := Evarconv.unify_leq_delay env !evdref univ ref_sort in let extract_pred_sort poly_ref = let evd, poly_ref = Evd.fresh_global (Global.env ()) !evdref poly_ref in evdref := evd; let ref_type = Retyping.get_type_of env !evdref poly_ref in let ref_sort = let _, _, typ = destProd !evdref ref_type in let _, _, typ = destProd !evdref typ in let _, a, _ = destProd !evdref typ in snd (decompose_prod !evdref a) in evdref := Evarconv.unify_leq_delay env !evdref univ ref_sort in List.iter extract_type_sort Program.([coq_eq_ind (); coq_eq_refl (); coq_eq_rect ()]); extract_pred_sort (Program.coq_eq_rect ()) let eq env evdref args = let evd, t = Program.papp env !evdref Program.coq_eq_ind args in evdref := evd; t let eq_refl env evdref args = let evd, t = Program.papp env !evdref Program.coq_eq_refl args in evdref := evd; t let transport env evdref args = let evd, t = Program.papp env !evdref Program.coq_eq_rect args in evdref := evd; t let proof_irrelevance env evdref args = let evd, t = Program.papp env !evdref (fun () -> Coqlib.lib_ref "core.proof_irrelevance") args in evdref := evd; t end let default_arity = 2 let hyps_from_rel_context env = let rctx = rel_context env in let rec aux acc depth = function [] -> acc | (_, None, _) :: tl -> aux (depth :: acc) (depth + 1) tl | _ :: tl -> aux acc (depth + 1) tl in let nc = (List.map fromDecl rctx) in aux [] 1 nc let compose_prod_decls rel_context init = Context.Rel.fold_inside(fun (acc : constr) d -> match fromDecl d with (x, None, typ) -> mkProd (x, typ, acc) | (x, Some def, typ) -> mkLetIn (x, def, typ, acc)) ~init rel_context let compose_lambda_decls rel_context init = Context.Rel.fold_inside(fun (acc : constr) d -> match fromDecl d with (x, None, typ) -> mkLambda (x, typ, acc) | (x, Some def, typ) -> mkLetIn (x, def, typ, acc)) ~init rel_context let decompose_prod_n_decls_by_prod sigma n = if n < 0 then failwith "decompose_prod_n_decls_by_prod: integer parameter must be positive"; let rec prodec_rec l n c = if Int.equal n 0 then l,c else match kind sigma c with | Prod (x,t,c) -> prodec_rec (Context.Rel.add (toDecl (x,None, t)) l) (n-1) c | LetIn (x,b,t,c) -> prodec_rec (Context.Rel.add (toDecl (x,Some b, t)) l) n c | Cast (c,_,_) -> prodec_rec l n c | _c -> failwith "decompose_prod_n_decls_by_prod: not enough assumptions" in prodec_rec Context.Rel.empty n let decompose_prod sigma = let rec prodec_rec l c = match kind sigma c with | Prod (x,t,c) -> prodec_rec ((x,t)::l) c | _ -> l,c in prodec_rec [] let decompose_lam sigma = let rec lamdec_rec l c = match kind sigma c with | Lambda (x,t,c) -> lamdec_rec ((x,t)::l) c | _ -> l,c in lamdec_rec [] let rec has_cast sigma t = let t = snd (decompose_lam sigma t) in let t = snd (decompose_prod sigma t) in isCast sigma t || fold sigma (fun acc t -> acc || has_cast sigma t) false t let prop_or_type _env _evdr s = s (* [prime order index c] replace all the free variable in c by its [index]-projection where 0 <= index < order. * Exemple, if c is a well-defined term in context x, y, z |- c, then [prime order index c] is * c[x_index/x,y_index/y, z_index/z] and is well-defined in: * x_1, x_2, ...,x_order, x_R, y_1, y_2, ..., y_order, y_R, z1, z_2, ..., z_order, z_R * *) let prime sigma order index c = let rec aux depth c = match kind sigma c with | Rel i -> if i <= depth then c else mkRel (depth + (order + 1) * (i - depth) - index) | _ -> map_with_binders sigma ((+) 1) aux depth c in aux 0 c (* [translate_string] provides a generic name for the translation of identifiers. *) let translate_string order x = match order with | 0 -> x | 1 -> x^"_P" | 2 -> x^"_R" | 3 -> x^"_T" | n -> x^"_R_"^(string_of_int n) (* [prime_string] provides a generic name for the projections of indentifiers. *) let prime_string order value x = if value >= order then translate_string order x else if order = 1 then x else match value with | 0 -> x^"₁" | 1 -> x^"₂" | 2 -> x^"₃" | n -> Printf.sprintf "%s_%d" x (n-1) (* The translation of identifiers. *) let translate_id order y = (Id.of_string @@ translate_string order @@ Id.to_string @@ y) (* The prime of identifiers. *) let prime_id order value y = (Id.of_string @@ prime_string order value @@ Id.to_string @@ y) (* The prime of names. *) let prime_name order value = function | Name y -> Name (prime_id order value y) | Anonymous -> Anonymous (* The translation of names. *) let translate_name order = function | Name y -> Name (translate_id order y) | Anonymous -> Anonymous (* (* l \in ⟦s⟧_3 = l₁ → l₂ → l₃ → t, * where t is Prop if s ∈ {Set, Prop} or s otherwise. *) let translate_sort l s = let rec aux k acc = function | [] -> acc | hd::tl -> let k = k - 1 in aux k (mkArrow (mkRel k) acc) tl in aux (List.length l) (prop_or_type s) l *) (* [range f n] computes [f n-1; f n-2; ...; f 0] *) let range f order = let rec aux k acc = if k < order then aux (k + 1) ((f k)::acc) else acc in aux 0 [] (* [rev_range f n] computes [f 0; f 1; ...; f n-1] *) let rev_range f order = List.rev (range f order) (* the iterator for natural numbers. *) let fold_nat f x = let rec aux acc n = if n = 0 then acc else let n = n - 1 in aux (f n acc) n in aux x (* [first n l] returns the first [n] elements of [l]. *) let firsts n l = fst (List.chop n l) (* If [t] is well-defined in G, x1, ..., xn, [apply_head_variables t n] returns * (t x1 ... xn) *) let apply_head_variables t n = let l = fold_nat (fun k l -> (mkRel (k + 1))::l) [] n in mkApp (t, Array.of_list (List.rev l)) let apply_head_variables_ctxt t ctxt = mkApp (t, Context.Rel.instance mkRel 0 ctxt) (* Substitution in a signature. *) let substnl_rel_context subst n sign = let rec aux n = function | d::sign -> substnl_decl subst n d :: aux (n+1) sign | [] -> [] in List.rev (aux n (List.rev sign)) let substl_rel_context subst = substnl_rel_context subst 0 (* If [c] is well-formed type in env [G], then [generalize G c] returns [forall G.c]. *) let generalize_env (env : Environ.env) (init : types) = let l = rel_context env in Context.Rel.fold_inside(fun x y -> mkProd_or_LetIn y x) l ~init (* If [c] is well-formed term in env [G], then [generalize G c] returns [fun G.c]. *) let abstract_env (env : Environ.env) (init : constr) = let l = rel_context env in Context.Rel.fold_inside(fun x y -> mkLambda_or_LetIn y x) l ~init let mkFreshInd env evd c = let evd', res = Evd.fresh_inductive_instance env !evd c in evd := evd'; of_constr @@ Constr.mkIndU res let mkFreshConstruct env evd c = let evd', res = Evd.fresh_constructor_instance env !evd c in evd := evd'; of_constr @@ Constr.mkConstructU res (* prodn n [xn:Tn;..;x1:T1;Gamma] b = (x1:T1)..(xn:Tn)b *) let prodn n env b = let rec prodrec = function | (0, _env, b) -> b | (n, ((v,t)::l), b) -> prodrec (n-1, l, mkProd (v,t,b)) | _ -> assert false in prodrec (n,env,b) (* compose_prod [xn:Tn;..;x1:T1] b = (x1:T1)..(xn:Tn)b *) let compose_prod l b = prodn (List.length l) l b (* lamn n [xn:Tn;..;x1:T1;Gamma] b = [x1:T1]..[xn:Tn]b *) let lamn n env b = let rec lamrec = function | (0, _env, b) -> b | (n, ((v,t)::l), b) -> lamrec (n-1, l, mkLambda (v,t,b)) | _ -> assert false in lamrec (n,env,b) (* compose_lam [xn:Tn;..;x1:T1] b = [x1:T1]..[xn:Tn]b *) let compose_lam l b = lamn (List.length l) l b (* G |- t ---> |G|, x1, x2 |- [x1,x2] in |t| *) let rec relation order evd env (t : constr) : constr = debug_string [`Relation] (Printf.sprintf "relation %d evd env t" order); debug_evar_map [`Relation] "evd =" env !evd; debug [`Relation] "input =" env !evd t; let res = match kind !evd t with | Sort s -> let r = Retyping.relevance_of_sort !evd s in fold_nat (fun _ -> mkArrow (mkRel order) r) (prop_or_type env evd t) order | Prod (x, a, b) -> let x = Context.map_annot (Namegen.named_hd env !evd a) x in let a_R = relation order evd env a in (* |G|, x1, x2 |- [x1,x2] in |a| *) let a_R = liftn order (order + 1) a_R in (*|G|, f1, f2, x1, x2 |- [x1,x2] in |a| *) let env = push_rel (toDecl (x, None, a)) env in let b_R = relation order evd env b in debug_string [`Relation] (Printf.sprintf "b has cast : %b" (has_cast !evd b)); debug_string [`Relation] (Printf.sprintf "b_R has cast : %b" (has_cast !evd b_R)); (* |G|, x1, x2, x_R, y1, y2 |- [y1,y2] in |b| *) let b_R = liftn order (2 * order + 2) b_R in debug_string [`Relation] (Printf.sprintf "b_R lifted has cast : %b" (has_cast !evd b_R)); (* |G|, f1, f2, x1, x2, x_R, y1, y2 |- [y1,y2] in |b| *) let fxs = fold_nat (fun k l -> (mkApp (mkRel (order + k + 2), [| mkRel (k + 2) |]))::l) [] order in (* |G|, f1, f2, x1, x2, x_R |- [f1 x1, f2 x2] *) let b_R = substl fxs b_R in debug_string [`Relation] (Printf.sprintf "b_R subste has cast : %b" (has_cast !evd b_R)); (* |G|, f1, f2, x_1, x_2, x_R |- [f1 x1, f2 x2] in |b| *) let x_R = Context.map_annot (translate_name order) x in let prods = range (fun k -> (Context.map_annot (prime_name order k) x, lift (order + k) (prime !evd order k a))) order in compose_prod prods (mkProd (x_R, a_R, b_R)) (* |G|, f1, f2 |- forall x_1, x_2, x_R, [f1 x1, f2 x2] in |b| *) | _ -> let t_R = translate order evd env t in debug_string [`Relation] (Printf.sprintf "t_R has cast : %b" (has_cast !evd t_R)); let t_R = lift order t_R in debug_string [`Relation] (Printf.sprintf "t_R lifted has cast : %b" (has_cast !evd t_R)); apply_head_variables t_R order in if !debug_mode && List.exists (fun x -> List.mem x [`Relation]) debug_flag then begin debug_string [`Relation] (Printf.sprintf "exit relation %d evd env t" order); debug_evar_map [`Relation] "evd =" env !evd; debug [`Relation] "input =" env !evd t; debug_string [`Relation] (Printf.sprintf "input has cast : %b" (has_cast !evd t)); debug_mode := false; let env_R = translate_env order evd env in let na = Namegen.named_hd env !evd t Anonymous in let lams = range (fun k -> (Context.make_annot (prime_name order k na) Sorts.Relevant, None, lift k (prime !evd order k t))) order in let env_R = push_rel_context (List.map toDecl lams) env_R in debug_mode := true; debug [`Relation] "output =" env_R !evd res; debug_string [`Relation] (Printf.sprintf "output has cast : %b" (has_cast !evd res)) end; res (* G |- t ---> |G| |- |t| *) and translate order evd env (t : constr) : constr = debug_string [`Translate] (Printf.sprintf "translate %d evd env t" order); debug_evar_map [`Translate] "evd =" env !evd; debug [`Translate] "input =" env !evd t; let res = match kind !evd t with | Rel n -> mkRel ( (n - 1) * (order + 1) + 1) | Sort _ | Prod (_,_,_) -> (* [..., _ : t'', _ : t', _ : t] *) let na = Namegen.named_hd env !evd t Anonymous in let lams = range (fun k -> (Context.make_annot (prime_name order k na) Sorts.Relevant, lift k (prime !evd order k t))) order in compose_lam lams (relation order evd env t) | App (c,l) -> let l = List.rev (Array.to_list l) in let l_R = List.flatten (List.map (fun x -> (translate order evd env x):: (range (fun k -> prime !evd order k x) order)) l) in applist (translate order evd env c, List.rev l_R) | Var i -> translate_variable order env evd i | Meta _n -> not_implemented ~reason:"meta" env !evd t | Cast (c, k, t) -> let c_R = translate order evd env c in let t_R = relation order evd env t in let sub = range (fun k -> prime !evd order k c) order in let t_R = substl sub t_R in mkCast (c_R, k, t_R) | Lambda (x, a, m) -> let lams = range (fun k -> (Context.map_annot (prime_name order k) x, lift k (prime !evd order k a))) order in let x_R = Context.map_annot (translate_name order) x in let a_R = relation order evd env a in let env = push_rel (toDecl (x, None, a)) env in compose_lam lams (mkLambda (x_R, a_R, translate order evd env m)) | LetIn (x, b, t, c) -> fold_nat (fun k acc -> mkLetIn (Context.map_annot (prime_name order k) x, lift k (prime !evd order k b), lift k (prime !evd order k t), acc)) (mkLetIn (Context.map_annot (translate_name order) x, lift order (translate order evd env b), relation order evd env t, let env = push_rel (toDecl (x, Some b, t)) env in translate order evd env c)) order | Const c -> translate_constant order evd env c | Fix _ -> translate_fix order evd env t | Ind indu -> translate_inductive order env evd indu | Construct cstru -> translate_constructor order env evd cstru | Case (ci, u, pms, p, iv, c, bl) -> let (ci, (p,r), iv, c, bl) = EConstr.expand_case env !evd (ci, u, pms, p, iv, c, bl) in let nargs, nparams = Inductiveops.inductive_nrealargs env ci.ci_ind, Inductiveops.inductive_nparams env ci.ci_ind in let theta = mkCase (EConstr.contract_case env !evd (ci, (lift (nargs + 1) p, r), Constr.map_invert (lift (nargs + 1)) iv, mkRel 1, Array.map (lift (nargs + 1)) bl)) in debug_case_info [`Case] ci; debug [`Case] "theta (in translated env) = " Environ.empty_env !evd theta; debug_string [`Case] (Printf.sprintf "nargs = %d, params = %d" nargs nparams); let ci_R = translate_case_info order env ci in debug_case_info [`Case] ci_R; debug [`Case] "p:" env !evd p; let lams, t = decompose_lambda_n_decls !evd (nargs + 1) p in let env_lams = push_rel_context lams env in debug [`Case] "t:" env_lams !evd t; let t_R = relation order evd env_lams t in debug [`Case] "t_R:" empty_env !evd t_R; let sub = range (fun k -> prime !evd order k theta) order in debug_string [`Case] "substitution :"; List.iter (debug [`Case] "" Environ.empty_env !evd) sub; let t_R = substl sub t_R in debug [`Case] "t_R" Environ.empty_env !evd t_R; let lams_R = translate_rel_context order evd env lams in let p_R = compose_lambda_decls lams_R t_R in let c_R = translate order evd env c in let bl_R = Array.map (translate order evd env) bl in let tuple = (EConstr.contract_case env !evd (ci_R, (p_R,r), Constr.NoInvert, c_R, bl_R)) in mkCase tuple | CoFix _ -> translate_cofix order evd env t | Proj (p, r, c) -> mkProj (Projection.map (fun cte -> Names.MutInd.make1 (Names.Constant.canonical (Globnames.destConstRef (Relations.get_constant order (Names.Constant.make1 (Names.MutInd.canonical cte)))))) p, r, translate order evd env c) | _ -> not_implemented ~reason:"trapfall" env !evd t in if !debug_mode && List.exists (fun x -> List.mem x [`Translate]) debug_flag then begin debug_string [`Translate] (Printf.sprintf "exit translate %d evd env t" order); debug_evar_map [`Translate] "evd =" env !evd; debug [`Translate] "input =" env !evd t; debug_string [`Translate] (Printf.sprintf "input has cast : %b" (has_cast !evd t)); debug_mode := false; let env_R = translate_env order evd env in debug_mode := true; debug [`Translate] "output =" env_R !evd res; debug_string [`Translate] (Printf.sprintf "output has cast : %b" (has_cast !evd res)) end; res and translate_constant order (evd : Evd.evar_map ref) env cst : constr = let kn, names_k = cst in let names = EInstance.kind !evd names_k in try let evd', constr = fresh_global ~rigid:Evd.univ_rigid ~names env !evd (Relations.get_constant order kn) in evd := evd'; constr with Not_found -> let cb = lookup_constant kn env in Declarations.(match cb.const_body with | Def _ -> let (value, _, constraints) = constant_value_and_type env (kn,names) in let evd' = Evd.add_constraints !evd constraints in evd := evd'; translate order evd env (of_constr (Option.get value)) | OpaqueDef op -> let typ = Typeops.type_of_constant_in env (kn,names) in (* See Coq's commit dc60b8c8934ba6d0f107dc1d9368f1172bd6f945 *) (* let cte_constraints = Declareops.constraints_of_constant table cb in *) (* let cte_constraints = Univ.subst_instance_constraints u cte_constraints in *) (* let evd' = Evd.add_constraints !evd cte_constraints in *) (* evd := evd'; *) let fold = mkConstU cst in let (def, _) = Global.force_proof Library.indirect_accessor op in let def = CVars.subst_instance_constr names def in let etyp = of_constr typ in let edef = of_constr def in let na = Namegen.named_hd env !evd etyp Anonymous in let pred = mkLambda (Context.make_annot na Sorts.Relevant, etyp, substl (range (fun _ -> mkRel 1) order) (relation order evd env etyp)) in let res = translate order evd env edef in let uf_opaque_stmt = CoqConstants.eq env evd [| etyp; edef; fold|] in let evd', sort = Typing.sort_of env !evd etyp in evd := evd'; let proof_opaque = try if Sorts.is_prop (ESorts.kind !evd sort) then (debug [`ProofIrrelevance] "def =" env !evd edef; debug [`ProofIrrelevance] "fold =" env !evd fold; CoqConstants.proof_irrelevance env evd [| etyp; edef; fold |]) else raise Not_found with e -> debug_string [`ProofIrrelevance] (Printexc.to_string e); let evd_, hole = new_evar_compat Environ.empty_env !evd uf_opaque_stmt in evd := evd_; CoqConstants.add_constraints evd (mkSort sort); hole in CoqConstants.transport env evd [| etyp; edef; pred; res; fold; proof_opaque |] | _ -> error (Pp.str (Printf.sprintf "The constant '%s' has no registered translation." (KerName.to_string (Constant.user (fst cst)))))) and translate_rel_context order evd env rc = let _, ll = Context.Rel.fold_outside (fun decl (env, acc) -> let (x, def, typ) = fromDecl decl in let x_R = Context.map_annot (translate_name order) x in let def_R = Option.map (translate order evd env) def in let typ_R = relation order evd env typ in let l = range (fun k -> toDecl (Context.map_annot (prime_name order k) x, Option.map (fun x -> lift k (prime !evd order k x)) def, lift k (prime !evd order k typ)) ) order in let env = push_rel decl env in env, ((toDecl ((x_R, Option.map (lift order) def_R, typ_R))::l))::acc) ~init:(env, []) rc in List.flatten ll and translate_variable order env evdr v : constr = try let evd, (cst,u) = Evd.fresh_constant_instance ~rigid:Evd.univ_rigid env !evdr (Relations.get_variable order v) in evdr := evd; mkConstU (cst,EInstance.make u) with Not_found -> error (Pp.str (Printf.sprintf "The variable '%s' has no registered translation, provide one with the Realizer command." (Names.Id.to_string v))) and translate_inductive order env evdr (ind, names) = try let names = EInstance.kind !evdr names in let evd, constr = fresh_global ~rigid:Evd.univ_rigid ~names env !evdr (Relations.get_inductive order ind) in evdr := evd; constr with Not_found -> error (Pp.str (Printf.sprintf "The inductive '%s' has no registered translation." (KerName.to_string (MutInd.user (fst ind))))) and translate_constructor order env evdr ((ind, i), u) = let (ind, u) = destInd !evdr (translate_inductive order env evdr (ind,u)) in mkConstructU ((ind, i), u) and translate_case_info order env ci = let ci_ind = try Globnames.destIndRef (Relations.get_inductive order ci.ci_ind) with Not_found -> error (Pp.str (Printf.sprintf "The inductive '%s' has no registered translation." (KerName.to_string (MutInd.user (fst ci.ci_ind))))) in { ci_ind = ci_ind; ci_npar = (order + 1) * ci.ci_npar; ci_cstr_ndecls = Array.map (fun x -> (order + 1) * x) ci.ci_cstr_ndecls; ci_cstr_nargs = Array.map (fun x -> (order + 1) * x) ci.ci_cstr_nargs; ci_pp_info = translate_case_printing order env ci.ci_pp_info; } and translate_case_printing order env cp = let translate_bool_list l = List.flatten (List.map (fun x -> range (fun _ -> x) (order + 1)) l) in { ind_tags = (range (fun _ -> false) order) @ translate_bool_list cp.ind_tags; cstr_tags = Array.map translate_bool_list cp.cstr_tags; style = translate_style cp.style } and translate_style x = x and translate_cofix order evd env t = let (index, (lna, tl, bl)) as fix = destCoFix !evd t in let nfun = Array.length lna in let rec letfix name fix typ n k acc = if k = 0 then acc else let k = k-1 in let r = lna.(n).binder_relevance in let fix_k = lift (n*order + k) (prime !evd order k fix) in let typ_k = lift (n*order + k) (prime !evd order k typ) in let acc = mkLetIn (Context.make_annot (Name (Id.of_string (Printf.sprintf "fix_%s_%d" name (k+1)))) r, fix_k, typ_k, acc) in letfix name fix typ n k acc in let rec letfixs n acc = if n = 0 then acc else let n = n - 1 in let name = match lna.(n).binder_name with | Name id -> Names.Id.to_string id | _ -> string_of_int n in let fix = mkCoFix (index, (lna, tl, bl)) in let typ = tl.(n) in let acc = letfix name fix typ n order acc in letfixs n acc in let nrealargs = Array.map (fun x -> Context.Rel.nhyps (fst (decompose_lambda_decls !evd x))) bl in (* [lna_R] is the translation of names of each fixpoints. *) let lna_R = Array.map (Context.map_annot (translate_name order)) lna in let ftbk_R = Array.mapi (fun i x -> let narg = nrealargs.(i) in let ft, bk = decompose_prod_n_decls_by_prod !evd narg x in let ft_R = translate_rel_context order evd env ft in let env_ft = push_rel_context ft env in let bk_R = relation order evd env_ft bk in (ft, ft_R, bk, bk_R)) tl in let tl_R = Array.mapi (fun n (ft, ft_R, bk, bk_R) -> (* bk_R is well-typed in | G, ft|, x_1 : bk_1, x_2 : bk_R *) (* we lift it to insert the [nfun * order] letins. *) let ft_R_len = Context.Rel.length ft_R in let bk_R = liftn (nfun * order) (ft_R_len + order + 1) bk_R in let sub = range (fun k -> mkApp (mkRel (ft_R_len + (nfun - n)*order - k ), Array.map (prime !evd order k) (Context.Rel.instance mkRel 0 ft))) order in compose_prod_decls (lift_rel_context (nfun * order) ft_R) (substl sub bk_R)) ftbk_R in (* env_rec is the environement under fixpoints. *) let env_rec = push_rec_types (lna, tl, bl) env in (* n : fix index *) let process_body n = let lams, body = decompose_lambda_decls !evd bl.(n) in let env_lams = push_rel_context lams env_rec in let narg = Context.Rel.length lams in let body_R = translate order evd env_lams body in let (ft, ft_R, bk, bk_R) = ftbk_R.(n) in let theta = mkApp (mkRel (nfun - n + narg), Context.Rel.instance mkRel 0 lams) in (* lift to insert fixpoints variables before arguments * plus possible letins that were not in the type. * *) let nfun_letins = nfun + narg - nrealargs.(n) in let bk = liftn nfun_letins (narg + 1) bk in let bk_R = liftn (nfun_letins * (order + 1)) ((order + 1) * narg + order + 1) bk_R in (* narg is the position of fixpoints in env *) let body_R = rewrite_cofixpoints order evd env_lams narg fix body theta bk bk_R body_R in let lams_R = translate_rel_context order evd env_rec lams in let res = compose_lambda_decls lams_R body_R in if List.exists (fun x -> List.mem x [`Fix]) debug_flag then begin let env_R = translate_env order evd env_rec in debug [`Fix] "res = " env_R !evd res; end; res in let bl_R = Array.init nfun process_body in let bl_R = (* example: if order = 2 and nfun = 3, then permut_sub is : [1;2;7;3;4;8;5;6;9] *) let suc_order = order + 1 in let size_of_sub = suc_order * nfun in let permut_sub = let l = List.init size_of_sub (fun x -> if x mod suc_order <> 0 then nfun + x - x / suc_order else 1 + x / suc_order) in List.map mkRel l in Array.map (fun x -> let x = liftn size_of_sub (size_of_sub + 1) x in substl permut_sub x) bl_R in let res = mkCoFix (index, (lna_R, tl_R, bl_R)) in let res = letfixs nfun res in if List.exists (fun x -> List.mem x [`Fix]) debug_flag then begin let env_R = translate_env order evd env in debug [`Fix] "cofix res = " env_R !evd res; end; res and translate_fix order evd env t = let ((ri, i) as ln, (lna, tl, bl)) as fix = destFix !evd t in let nfun = Array.length lna in let rec letfix name fix typ n k acc = if k = 0 then acc else let k = k-1 in let r = lna.(n).binder_relevance in let fix_k = lift (n*order + k) (prime !evd order k fix) in let typ_k = lift (n*order + k) (prime !evd order k typ) in let acc = mkLetIn (Context.make_annot (Name (Id.of_string (Printf.sprintf "fix_%s_%d" name (k+1)))) r, fix_k, typ_k, acc) in letfix name fix typ n k acc in let rec letfixs n acc = if n = 0 then acc else let n = n - 1 in let name = match lna.(n).binder_name with | Name id -> Names.Id.to_string id | _ -> string_of_int n in let fix = mkFix ((ri, n), (lna, tl, bl)) in let typ = tl.(n) in let acc = letfix name fix typ n order acc in letfixs n acc in let nrealargs = Array.map (fun x -> Context.Rel.nhyps (fst (decompose_lambda_decls !evd x))) bl in (* [ln_R] is the translation of ln, the array of arguments for each fixpoints. *) let ln_R = (Array.map (fun x -> x*(order + 1) + order) ri, i) in (* [lna_R] is the translation of names of each fixpoints. *) let lna_R = Array.map (Context.map_annot (translate_name order)) lna in let ftbk_R = Array.mapi (fun i x -> let narg = nrealargs.(i) in let ft, bk = decompose_prod_n_decls_by_prod !evd narg x in let ft_R = translate_rel_context order evd env ft in let env_ft = push_rel_context ft env in let bk_R = relation order evd env_ft bk in (ft, ft_R, bk, bk_R)) tl in let tl_R = Array.mapi (fun n (ft, ft_R, bk, bk_R) -> (* bk_R is well-typed in | G, ft|, x_1 : bk_1, x_2 : bk_R *) (* we lift it to insert the [nfun * order] letins. *) let ft_R_len = Context.Rel.length ft_R in let bk_R = liftn (nfun * order) (ft_R_len + order + 1) bk_R in let sub = range (fun k -> mkApp (mkRel (ft_R_len + (nfun - n)*order - k ), Array.map (prime !evd order k) (Context.Rel.instance mkRel 0 ft))) order in compose_prod_decls (lift_rel_context (nfun * order) ft_R) (substl sub bk_R)) ftbk_R in (* env_rec is the environement under fixpoints. *) let env_rec = push_rec_types (lna, tl, bl) env in (* n : fix index *) let process_body n = let lams, body = decompose_lambda_decls !evd bl.(n) in let narg = Context.Rel.length lams in (* rec_arg gives the position of the recursive argument *) let rec_arg = narg - (fst ln).(n) in let args = Context.Rel.instance_list mkRel 0 lams in let lams_R = translate_rel_context order evd env_rec lams in let env_lams = push_rel_context lams env_rec in let inst_args depth args = mkApp (mkRel (depth + nfun - n + narg), Array.of_list args) in (* we use this complicated function to translate the * shallow cases just after a lambda (the goal is to * avoid as much as possible rewriting). * *) let rec traverse_cases env depth (args : constr list) typ typ_R term = match kind !evd term with | Case (ci, _, _, p, _, c, branches) when test_admissible env c args p branches -> process_case env depth args term | _ -> (* otherwise we have to perform some rewriting. *) debug [`Fix] "c = " env !evd term; debug [`Fix] "typ = " env !evd typ; let term_R = translate order evd env term in let theta = inst_args depth args in (* depth + narg is the position of fixpoints in env *) rewrite_fixpoints order evd env (depth + narg) fix term theta typ typ_R term_R and test_admissible env c args _predicate branches = isRel !evd c && List.mem c args && Array.for_all (fun (nas, br) -> noccurn !evd (destRel !evd c + Array.length nas) br) branches && let typ = Retyping.get_type_of env !evd c in debug [`Fix] "typ = " env !evd typ; List.iteri (fun i x -> debug [`Fix] (Printf.sprintf "args.(%d) = " i) env !evd x) args; let (ind, u), ind_args = Inductiveops.find_inductive env !evd typ in let nparams = Inductiveops.inductive_nparams env ind in let _, realargs = List.chop nparams ind_args in let erealargs = List.map of_constr realargs in List.iteri (fun i x -> debug [`Fix] (Printf.sprintf "realargs.(%d) = " i) env !evd x) erealargs; List.for_all (fun x -> List.mem x args) erealargs and process_case env depth (fun_args : constr list) case = debug [`Fix] "case = " env !evd case; let (ci, (p,r), iv, c, bl) = EConstr.expand_case env !evd (destCase !evd case) in debug [`Fix] "predicate = " env !evd p; let c_R = translate order evd env c in let ci_R = translate_case_info order env ci in let c_typ = Retyping.get_type_of env !evd c in debug [`Fix] "c_typ = " env !evd c_typ; let ((ind, u) as pind, params_args) = Inductiveops.find_inductive env !evd c_typ in let i_nargs, i_nparams = Inductiveops.inductive_nrealargs env ind, Inductiveops.inductive_nparams env ind in let i_params, i_realargs = List.chop i_nparams params_args in debug_string [`Fix] "make inductive family ..."; let ind_fam = Inductiveops.make_ind_family ((ind, EInstance.kind !evd u), i_params) in debug_string [`Fix] "get_constructors"; let constructors = Inductiveops.get_constructors env ind_fam in debug_string [`Fix] "done"; assert (List.length i_realargs = i_nargs); let ei_realargs = List.map of_constr i_realargs in let fun_args_i = List.map (fun x -> if x = c then mkRel 1 else if List.mem x ei_realargs then mkRel (2 + i_nargs - (List.index (=) x ei_realargs)) else lift (i_nargs + 1) x) fun_args in let theta = inst_args (depth + i_nargs + 1) fun_args_i in let sub = range (fun k -> prime !evd order k theta) order in let lams, typ = decompose_lambda_n_decls !evd (i_nargs + 1) p in debug [`Fix] "theta = " (push_rel_context lams env) !evd theta; debug [`Fix] "theta = " Environ.empty_env !evd theta; let lams_R = translate_rel_context order evd env lams in let env_lams = push_rel_context lams env in let typ_R = relation order evd env_lams typ in let p_R = substl sub typ_R in let p_R = compose_lambda_decls lams_R p_R in debug [`Fix] "predicate_R = " Environ.empty_env !evd p_R; let bl_R = debug_string [`Fix] (Printf.sprintf "dest_rel = %d" (destRel !evd c)); debug_string [`Fix] (Printf.sprintf "depth = %d" depth); debug_string [`Fix] (Printf.sprintf "barg = %d" narg); debug_string [`Fix] (Printf.sprintf "fst ln = %d" (fst ln).(n)); debug_string [`Fix] (Printf.sprintf "rec_arg = %d" rec_arg); if (destRel !evd c) = depth + rec_arg then Array.map (translate order evd env) bl else begin Array.mapi (fun i b -> let (cstr, u) as cstru = constructors.(i).Inductiveops.cs_cstr in let pcstr = mkConstructU (cstr, EInstance.make u) in let nrealdecls = Inductiveops.constructor_nrealdecls env cstr in let realdecls, b = decompose_lambda_n_decls !evd nrealdecls b in let ei_params = List.map of_constr i_params in let lifted_i_params = List.map (lift nrealdecls) ei_params in let instr_cstr = mkApp (pcstr, Array.of_list (List.append lifted_i_params (Context.Rel.instance_list mkRel 0 realdecls))) in let concls = constructors.(i).Inductiveops.cs_concl_realargs in assert (Array.length concls = i_nargs); let fun_args = List.map (fun x -> if x = c then instr_cstr else if List.mem x ei_realargs then (of_constr @@ concls.(i_nargs - (List.index (=) x ei_realargs))) else lift nrealdecls x) fun_args in let realdecls_R = translate_rel_context order evd env realdecls in let sub = instr_cstr::(List.map of_constr @@ List.rev (Array.to_list concls)) in let typ = substl sub typ in (* FIXME : translate twice here :*) let typ_R = relation order evd env_lams typ in let env = push_rel_context realdecls env in let b_R = traverse_cases env (depth + nrealdecls) fun_args typ typ_R b in compose_lambda_decls realdecls_R b_R ) bl end in mkCase (EConstr.contract_case env !evd (ci_R, (p_R,r), iv, c_R, bl_R)) in let (_, ft_R, bk, bk_R) = ftbk_R.(n) in let nfun_letins = nfun + narg - nrealargs.(n) in (* lift to insert fixpoints variables before arguments * plus possible letins that were not in the type. * *) let bk = liftn nfun_letins (narg + 1) bk in let bk_R = liftn (nfun_letins * (order + 1)) ((order + 1) * narg + order + 1) bk_R in let body_R = traverse_cases env_lams 0 args bk bk_R body in let res = compose_lambda_decls lams_R body_R in if List.exists (fun x -> List.mem x [`Fix]) debug_flag then begin let env_R = translate_env order evd env_rec in debug [`Fix] "res = " env_R !evd res; end; res in let bl_R = Array.init nfun process_body in let bl_R = (* example: if order = 2 and nfun = 3, then permut_sub is : [1;2;7;3;4;8;5;6;9] *) let suc_order = order + 1 in let size_of_sub = suc_order * nfun in let permut_sub = let l = List.init size_of_sub (fun x -> if x mod suc_order <> 0 then nfun + x - x / suc_order else 1 + x / suc_order) in List.map mkRel l in Array.map (fun x -> let x = liftn size_of_sub (size_of_sub + 1) x in substl permut_sub x) bl_R in let res = mkFix (ln_R, (lna_R, tl_R, bl_R)) in letfixs nfun res (* for debugging only *) and translate_env order evdr env = let init_env = Environ.reset_context env in let rc = translate_rel_context order evdr init_env (rel_context env) in push_rel_context rc init_env (* Γ ⊢ source : typ * Γ ⊢ target : typ * ⟦Γ⟧, typ₁, typ₂ ⊢ typ_R : Type * * builds : * * * *) and rewrite_fixpoints order evdr env (depth : int) (fix : fixpoint) source target typ typ_R acc = debug [`Fix] "source =" env !evdr source; debug [`Fix] "target =" env !evdr target; debug [`Fix] "typ =" env !evdr typ; let env_R = if List.exists (fun x -> List.mem x [`Fix]) debug_flag then begin let env_R = translate_env order evdr env in let rc_order = rev_range (fun k -> Context.make_annot (Name (Id.of_string (Printf.sprintf "rel_%d" k))) Sorts.Relevant, None, lift k (prime !evdr order k typ)) order in let env_R' = push_rel_context (List.map toDecl rc_order) env_R in debug [`Fix] "typ_R =" env_R' !evdr typ_R; env_R end else env in let instantiate_fixpoint_in_rel_context rc = let (ri, k), stuff = fix in let pos = depth in let nfun = Array.length ri in let front, back = List.chop pos rc in let funs, back = List.chop nfun back in let fixs = List.mapi (fun i -> function (name, None, typ) -> (name, Some (mkFix ((ri, nfun - 1 - i), stuff)), typ) | _ -> assert false) funs in front @ fixs @ back in let env_rc = rel_context env in let env_rc = instantiate_fixpoint_in_rel_context (List.map fromDecl env_rc) in let path = CoqConstants.eq env evdr [| typ; source; target|] in debug [`Fix] "path" env !evdr path; let gen_rc, new_vec, path = weaken_unused_free_rels env_rc !evdr path in let gen_path_type = it_mkProd_or_LetIn path gen_rc in debug [`Fix] "gen_path_type" Environ.empty_env !evdr gen_path_type; let evd, hole = new_evar_compat Environ.empty_env !evdr gen_path_type in evdr := evd; let let_gen acc = mkLetIn (Context.make_annot (Name (Id.of_string "gen_path")) Sorts.Relevant, hole, gen_path_type, acc) in let env_R' = let decl_gen_path = Context.Rel.Declaration.LocalDef (Context.make_annot (Name (Id.of_string "gen_path")) Sorts.Relevant,hole,gen_path_type) in push_rel decl_gen_path env_R in let res1 = (fold_nat (fun k acc -> let pred_sub = (range (fun x -> lift 1 (prime evd order (k+1+x) target)) (order-1 - k)) @ [ mkRel 1 ] @ (range (fun x -> lift 1 (prime evd order x source)) k) in let sort = Retyping.get_type_of env !evdr typ in let r = Retyping.relevance_of_type env !evdr typ in CoqConstants.add_constraints evdr sort; let index = lift 1 (prime evd order k typ) in let pred = mkLambda (mkannot (Name (Id.of_string "x")) r, index, liftn 1 2 (substl pred_sub (liftn 1 (order + 1) typ_R))) in debug [`Fix] "pred = " env_R' !evdr pred; let base = lift 1 (prime evd order k source) in let endpoint = lift 1 (prime evd order k target) in let path = mkApp (mkRel 1, Array.map (fun x -> lift 1 (prime evd order k x)) new_vec) in CoqConstants.transport env evdr [| index; base; pred; acc; endpoint; path |]) (lift 1 acc) order) in let res = let_gen @@ res1 in debug [`Fix] "res1 = " env_R' !evdr res1; debug [`Fix] "gen_path_type" env_R !evdr gen_path_type; debug [`Fix] "res = " env_R !evdr res; res and weaken_unused_free_rels env_rc sigma term = (* Collect the dependencies with [vars] in a rel_context. *) let rec collect_free_vars k vars = function | [] -> vars | decl::tl when Int.Set.mem k vars -> let fv = match decl with (_, None, typ) -> Termops.free_rels sigma typ | (_, Some def, typ) -> Int.Set.union (Termops.free_rels sigma def) (Termops.free_rels sigma typ) in let vars = Int.Set.fold (fun x -> Int.Set.add (x + k)) fv vars in collect_free_vars (k + 1) vars tl | _::tl -> collect_free_vars (k + 1) vars tl in let rec apply_substitution_rel_context k sub acc = function [] -> List.rev acc | decl :: tl when destRel sigma (List.hd sub) > 0 -> let sub = List.tl sub in let decl = substl_decl (List.map (lift (-k)) sub) decl in apply_substitution_rel_context (k + 1) sub (decl::acc) tl | _ :: tl -> apply_substitution_rel_context k (List.tl sub) acc tl in debug_rel_context [`Fix] "env_rv = " Environ.empty_env (List.map toDecl env_rc); let set = collect_free_vars 1 (Termops.free_rels sigma term) env_rc in let lst = Int.Set.fold (fun x acc -> x::acc) set [] in let lst = List.sort compare lst in debug_string [`Fix] (Printf.sprintf "[%s]" (String.concat ";" (List.map string_of_int lst))); let rec dup n x acc = if n <= 0 then acc else dup (n-1) x (x::acc) in let rec gen_sub min pos len acc = function [] -> dup (len - min) 0 acc | hd :: tl -> let n = hd - min - 1 in let acc = pos::(dup n 0 acc) in gen_sub hd (pos + 1) len acc tl in let sub_lst = List.rev (gen_sub 0 1 (List.length env_rc) [] lst) in debug_string [`Fix] (Printf.sprintf "[%s]" (String.concat ";" (List.map string_of_int sub_lst))); let sub = List.map mkRel sub_lst in let new_env_rc = apply_substitution_rel_context 1 sub [] (List.map toDecl env_rc) in let new_vec = Context.Rel.instance_list mkRel 0 (List.map toDecl env_rc) in let new_vec = List.filter (fun x -> let v = destRel sigma x in Int.Set.mem v set) new_vec in let new_vec = Array.of_list new_vec in assert (Array.length new_vec == Context.Rel.nhyps new_env_rc); new_env_rc, new_vec, substl sub term and rewrite_cofixpoints order evdr env (depth : int) (fix : cofixpoint) source target typ typ_R acc = debug [`Fix] "source =" env !evdr source; debug [`Fix] "target =" env !evdr target; debug [`Fix] "typ =" env !evdr typ; let r = Retyping.relevance_of_type env !evdr typ in if List.exists (fun x -> List.mem x [`Fix]) debug_flag then begin let env_R = translate_env order evdr env in let rc_order = rev_range (fun k -> mkannot (Name (Id.of_string (Printf.sprintf "rel_%d" k))) r, None, lift k (prime !evdr order k typ)) order in let env_R = push_rel_context (List.map toDecl rc_order) env_R in debug [`Fix] "typ_R =" env_R !evdr typ_R end; let instantiate_fixpoint_in_rel_context rc = let index, ((lna, _, _) as stuff) = fix in let pos = depth in let nfun = Array.length lna in let front, back = List.chop pos rc in let funs, back = List.chop nfun back in let fixs = List.mapi (fun i -> function (name, None, typ) -> (name, Some (mkCoFix ((nfun - 1 - index), stuff)), typ) | _ -> assert false) funs in front @ fixs @ back in let env_rc = rel_context env in let env_rc = instantiate_fixpoint_in_rel_context (List.map fromDecl env_rc) in let gen_path = it_mkProd_or_LetIn (CoqConstants.eq env evdr [| typ; source; target|]) (List.map toDecl env_rc) in debug [`Fix] "gen_path_type" env !evdr gen_path; let evd, hole = new_evar_compat Environ.empty_env !evdr gen_path in evdr := evd; let let_gen acc = mkLetIn (mkannot (Name (Id.of_string "gen_path")) Sorts.Relevant, hole, gen_path, acc) in let_gen @@ (fold_nat (fun k acc -> let pred_sub = (range (fun x -> lift 1 (prime evd order (k+1+x) target)) (order-1 - k)) @ [ mkRel 1 ] @ (range (fun x -> lift 1 (prime evd order x source)) k) in let index = lift 1 (prime evd order k typ) in let pred = mkLambda (mkannot (Name (Id.of_string "x")) r, index, liftn 1 2 (substl pred_sub (liftn 1 (order + 1) typ_R))) in let base = lift 1 (prime evd order k source) in let endpoint = lift 1 (prime evd order k target) in let path = mkApp (mkRel 1, Array.map (fun x -> lift 1 (prime evd order k x)) (Context.Rel.instance mkRel 0 (List.map toDecl env_rc))) in let sort = Retyping.get_type_of env !evdr typ in CoqConstants.add_constraints evdr sort; CoqConstants.transport env evdr [| index; base; pred; acc; endpoint; path |]) (lift 1 acc) order) open Entries open Declarations (* Translation of inductives. *) let rec translate_mind_body name order evdr env kn b inst = (* XXX: What is going on here? This doesn't make sense after cumulativity *) (* let env = push_context b.mind_universes env in *) debug_string [`Inductive] "computing envs ..."; debug_env [`Inductive] "translate_mind, env = \n" env !evdr; debug_evar_map [`Inductive] "translate_mind, evd = \n" env !evdr; let envs = let params = CVars.subst_instance_context inst b.mind_params_ctxt in let env_params = push_rel_context (List.map of_rel_decl params) env in let env_arities = List.fold_left (fun env ind -> let typename = ind.mind_typename in debug_string [`Inductive] (Printf.sprintf "Adding '%s' to the environement." (Names.Id.to_string typename)); let full_arity, cst = Inductive.constrained_type_of_inductive ((b, ind), inst) in let r = ind.mind_relevance in let env = push_rel (toDecl (mkannot (Names.Name typename) r, None, (of_constr full_arity))) env in let env = Environ.add_constraints cst env in env ) env (Array.to_list b.mind_packets) in let env_arities_params = push_rel_context (List.map of_rel_decl params) env_arities in (env_params, params, env_arities, env_arities_params) in debug_string [`Inductive] "translatation of params ..."; let mind_entry_params_R = translate_mind_param order evdr env (CVars.subst_instance_context inst b.mind_params_ctxt) in debug_string [`Inductive] "translatation of inductive ..."; let mind_entry_inds_R = List.mapi (fun i x -> translate_mind_inductive name order evdr env (kn,i) b inst envs x) (Array.to_list b.mind_packets) in debug_evar_map [`Inductive] "translate_mind, evd = \n" env !evdr; let univs = match b.mind_universes with | Monomorphic -> begin match b.mind_template with | None -> Monomorphic_ind_entry | Some t -> Template_ind_entry t.Declarations.template_context end | Polymorphic _ -> let uctx, _ = (Evd.univ_entry ~poly:true !evdr) in match uctx with Polymorphic_entry uctx -> Polymorphic_ind_entry uctx | _ -> assert false in let res = { mind_entry_record = None; mind_entry_finite = b.mind_finite; mind_entry_params = mind_entry_params_R; mind_entry_inds = mind_entry_inds_R; mind_entry_universes = univs; mind_entry_variance = None; mind_entry_private = b.mind_private; } in Debug.debug_mutual_inductive_entry !evdr res; res and translate_mind_param order evd env (l : (Constr.constr, Constr.constr) Context.Rel.pt) = let ctoe c = let x, def, typ = fromDecl c in toDecl (x, Option.map of_constr def, of_constr typ) in let etoc c = let x, def, typ = fromDecl c in toCDecl (x, Option.map (to_constr !evd) def, to_constr !evd typ) in let l = List.map ctoe l in let l = translate_rel_context order evd env l in List.map etoc l and translate_mind_inductive name order evdr env ikn mut_entry inst (env_params, params, env_arities, env_arities_params) e = let p = List.length mut_entry.mind_params_ctxt in Debug.debug_string [`Inductive] (Printf.sprintf "mind_nparams = %d" mut_entry.mind_nparams); Debug.debug_string [`Inductive] (Printf.sprintf "mind_nparams_rec = %d" p); Debug.debug_string [`Inductive] (Printf.sprintf "mind_nparams_ctxt = %d" (List.length mut_entry.mind_params_ctxt)); let _, arity = decompose_prod_n_decls !evdr p (of_constr @@ Inductive.type_of_inductive ((mut_entry, e), inst)) in debug [`Inductive] "Arity:" env_params !evdr arity; let arity_R = debug_string [`Inductive] "Computing arity"; let arity_R = relation order evdr env_params arity in let inds = List.rev (fold_nat (fun k acc -> prime !evdr order k (apply_head_variables_ctxt (mkIndU (ikn, EInstance.make inst)) params)::acc) [] order) in debug_string [`Inductive] "Substitution:"; List.iter (debug [`Inductive] "" Environ.empty_env Evd.empty) inds; let result = substl inds arity_R in if List.exists (fun x -> List.mem x [`Inductive]) debug_flag then begin let env_params_R = translate_env order evdr env_params in debug [`Inductive] "Arity_R after substitution:" env_params_R !evdr result; end; result in let trans_consname s = translate_id order (Id.of_string ((Id.to_string name)^"_"^(Id.to_string s))) in { mind_entry_typename = name; mind_entry_arity = to_constr !evdr arity_R; mind_entry_consnames = List.map trans_consname (Array.to_list e.mind_consnames); mind_entry_lc = begin debug_string [`Inductive] "Computing constructors"; let l = Array.to_list e.mind_user_lc in let ntyps = Array.length mut_entry.mind_packets in let l = List.map (Inductive.abstract_constructor_type_relatively_to_inductive_types_context ntyps (fst ikn)) l in let l = List.map (CVars.subst_instance_constr inst) l in debug_string [`Inductive] "before translation :"; List.iter (debug [`Inductive] "" env_arities !evdr) (List.map of_constr l); let l = List.map (fun x -> snd (decompose_prod_n_decls !evdr p x)) (List.map of_constr l) in debug_string [`Inductive] "remove uniform parameters :"; List.iter (debug [`Inductive] "" env_arities_params !evdr) l; (* let sub = range (fun k -> mkRel (mut_entry.mind_nparams_rec + k + 1)) mut_entry.mind_nparams_rec in let l = List.map (substl sub) l in debug_string "reverse parameters and inductive variables :"; List.map (debug Environ.empty_env) l;*) let l = List.map (relation order evdr env_arities_params) l in let for_each_constructor k = (* Elements Ti of l are defined in the translation of the context : * [A'1;...;A'n;x1:X1;...;xn:Xp] * augmented with * y_1 : Ti_1, y_2 : Ti_2 * which is * [A'1_1; A'1_2; A'1_R;...;A'n_1;A'n_2;A'n_R;x1_1:X1_1; x1_2:X1_2, x1_R : ...] * * We then replace the variables A'i_j by the original inductive and we let the * A'1_R and the xi_j untouched. Finally we subtitue all the y_i by constructors. * * * Therefore the substitution is the reverse list of : * [I1, I1, Rel , * ..., * Ip, Ip, Rel, * Rel , Rel , Rel , * ... * Rel , Rel , Rel , * mkConstruct Cil, mkConstruct Cil ] * *) let n = Array.length mut_entry.mind_packets in let (kn, i) = ikn in let first_part = List.flatten (range (fun k -> let k' = n-1-k in (mkRel ((order + 1)*p + k'+1))::(range (fun _ -> mkIndU ((kn, k), EInstance.make inst)) order)) n) in let second_part = List.flatten @@ List.rev @@ (List.map List.rev) (range (fun k -> (mkRel ((order + 1)*(k+1)))::(range (fun i -> mkRel ((order + 1)*k + i + 1)) order)) p) in debug_string [`Inductive] (Printf.sprintf "constructor n°%d" k); let third_part = range (fun m -> prime !evdr order m (apply_head_variables_ctxt (mkConstructU ((ikn, k + 1), EInstance.make inst)) params)) order in let final_substitution = third_part @ second_part @ (first_part) in debug_string [`Inductive] "substitution :"; List.iter (debug [`Inductive] "" Environ.empty_env Evd.empty) final_substitution; substl final_substitution in debug_string [`Inductive] "before substitution:"; List.iter (debug [`Inductive] "" Environ.empty_env Evd.empty) l; let result = List.mapi for_each_constructor l in debug_string [`Inductive] "after substitution:"; List.iter (debug [`Inductive] "" Environ.empty_env Evd.empty) result; List.map (to_constr !evdr) result end } paramcoq-1.1.3-coq8.19/src/relations.ml000066400000000000000000000057771454026223400175620ustar00rootroot00000000000000(**************************************************************************) (* *) (* ParamCoq *) (* Copyright (C) 2012 - 2018 *) (* *) (* See the AUTHORS file for the list of contributors *) (* *) (* This file is distributed under the terms of the MIT License *) (* *) (**************************************************************************) open Ltac_plugin open Names open Globnames open Libobject let (set_parametricity_tactic, get_parametricity_tactic, print_parametricity_tactic) = Tactic_option.declare_tactic_option "Parametricity tactic" module IntMap = Map.Make(Int) module GMap = GlobRef.Map let initial_translations = GMap.empty let initial_relations = IntMap.empty let relations = Summary.ref initial_relations ~name:"parametricity" let print_relations () = IntMap.iter (fun n translations -> GMap.iter (fun gref c -> Feedback.(msg_info (Printer.pr_global gref))) translations ) !relations let add (n : int) f = let translations = try IntMap.find n !relations with Not_found -> initial_translations in relations := IntMap.add n (f translations) !relations let cache_relation (n, x, x_R) = add n (GMap.add x x_R) let discharge_relation (n, x, x_R) = Some (n, x, x_R) let subst_relation (subst, (n, x, x_R)) = (n, subst_global_reference subst x, subst_global_reference subst x_R) let in_relation = declare_object {(default_object "PARAMETRICITY") with cache_function = cache_relation; load_function = (fun _ -> cache_relation); subst_function = subst_relation; classify_function = (fun obj -> Substitute); discharge_function = discharge_relation} let declare_relation n x x_R = Lib.add_leaf (in_relation (n, x, x_R)) let declare_constant_relation (n : int) (c : Constant.t) (c_R : Constant.t) = declare_relation n (GlobRef.ConstRef c) (GlobRef.ConstRef c_R) let declare_inductive_relation (n : int) (i : inductive) (i_R : inductive) = declare_relation n (GlobRef.IndRef i) (GlobRef.IndRef i_R) let declare_variable_relation (n : int) (v : variable) (v_R : Constant.t) = declare_relation n (GlobRef.VarRef v) (GlobRef.ConstRef v_R) let get_constant n c = let map = IntMap.find n !relations in GMap.find (GlobRef.ConstRef c) map let get_inductive n i = let map = IntMap.find n !relations in GMap.find (GlobRef.IndRef i) map let get_variable n v = let map = IntMap.find n !relations in destConstRef (GMap.find (GlobRef.VarRef v) map) let is_referenced n ref = try let map = IntMap.find n !relations in GMap.mem ref map with Not_found -> false paramcoq-1.1.3-coq8.19/test-suite/000077500000000000000000000000001454026223400165275ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/test-suite/ListQueue.v000066400000000000000000000107611454026223400206430ustar00rootroot00000000000000Require Import Parametricity. Require Import List. Import ListNotations. Definition bind_option {A B} (f : A -> option B) (x : option A) : option B := match x with | Some x => f x | None => None end. Notation "'do' X <- A 'in' B" := (bind_option (fun X => B) A) (at level 200, X ident, A at level 100, B at level 200). Definition bind_option2 {A B C} (f : A -> B -> option C) (x : option (A * B)) : option C := do yz <- x in let (y, z) := yz : A * B in f y z. Notation "'do' X , Y <- A 'in' B" := (bind_option2 (fun X Y => B) A) (at level 200, X ident, Y ident, A at level 100, B at level 200). Require Import List. Record Queue := { t :> Type; empty : t; push : nat -> t -> t; pop : t -> option (nat * t) }. Definition program (Q : Queue) (n : nat) : option nat := (* q := 0::1::2::...::n *) let q : Q := nat_rect (fun _ => Q) Q.(empty) Q.(push) (S n) in let q : option Q := nat_rect (fun _ => option Q) (Some q) (fun _ (q : option Q) => do q <- q in do x, q <- Q.(pop) q in do y, q <- Q.(pop) q in Some (Q.(push) (x + y) q)) n in do q <- q in option_map fst (Q.(pop) q). Definition ListQueue := {| t := list nat; empty := nil; push := @cons nat; pop := fun l => match rev l with | nil => None | hd :: tl => Some (hd, rev tl) end |}. Definition DListQueue := {| t := list nat * list nat; empty := (nil, nil); push x l := let (back, front) := l in (cons x back,front); pop := fun l => let (back, front) := l in match front with | [] => match rev back with | [] => None | hd :: tl => Some (hd, (nil, tl)) end | hd :: tl => Some (hd, (back, tl)) end |}. Parametricity Recursive nat. Print nat_R. Lemma nat_R_equal : forall x y, nat_R x y -> x = y. intros x y H; induction H; subst; trivial. Defined. Lemma equal_nat_R : forall x y, x = y -> nat_R x y. intros x y H; subst. induction y; constructor; trivial. Defined. Parametricity Recursive option. Lemma option_nat_R_equal : forall x y, option_R nat nat nat_R x y -> x = y. intros x1 x2 H; destruct H as [x1 x2 x_R | ]. rewrite (nat_R_equal _ _ x_R); reflexivity. reflexivity. Defined. Lemma equal_option_nat_R : forall x y, x = y -> option_R nat nat nat_R x y. intros x y H; subst. destruct y; constructor; apply equal_nat_R; reflexivity. Defined. Parametricity Recursive prod. Parametricity Recursive Queue. Print Queue_R. Check Queue_R. Notation Bisimilar := Queue_R. Print Queue_R. Definition R (l1 : list nat) (l2 : list nat * list nat) := let (back, front) := l2 in l1 = back ++ rev front. Lemma rev_app : forall A (l1 l2 : list A), rev (l1 ++ l2) = rev l2 ++ rev l1. induction l1. intro; symmetry; apply app_nil_r. intro; simpl; rewrite IHl1; rewrite app_assoc. reflexivity. Defined. Lemma rev_list_rect A : forall P:list A-> Type, P [] -> (forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) -> forall l:list A, P (rev l). Proof. induction l; auto. Defined. Theorem rev_rect A : forall P:list A -> Type, P [] -> (forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l. Proof. intros. generalize (rev_involutive l). intros E; rewrite <- E. apply (rev_list_rect _ P). auto. simpl. intros. apply (X0 a (rev l0)). auto. Defined. Lemma bisim_list_dlist : Bisimilar ListQueue DListQueue. apply (Queue_R_Build_Queue_R _ _ R). * reflexivity. * intros n1 n2 n_R. pose (nat_R_equal _ _ n_R) as H. destruct H. clear n_R. intros l [back front]. unfold R. simpl. intro; subst. simpl. reflexivity. * intros l [back front]. generalize l. clear l. unfold R; fold R. pattern back. apply rev_rect. intros l H; subst. rewrite rev_app. simpl. rewrite app_nil_r. rewrite rev_involutive. destruct front. constructor. repeat constructor. apply equal_nat_R; reflexivity. clear back; intros hd back IHR l H. subst. rewrite rev_app. rewrite rev_involutive. rewrite rev_app. simpl. destruct front. simpl. repeat constructor. apply equal_nat_R; reflexivity. simpl. repeat constructor. apply equal_nat_R; reflexivity. unfold R. rewrite rev_app. simpl. rewrite rev_involutive. reflexivity. Defined. Print program. Check program. Parametricity Recursive program. Check program_R. Lemma program_independent : forall n, program ListQueue n = program DListQueue n. intro n. apply option_nat_R_equal. apply program_R. apply bisim_list_dlist. apply equal_nat_R. reflexivity. Defined. Print program. Print program_R. paramcoq-1.1.3-coq8.19/test-suite/Makefile000066400000000000000000000015621454026223400201730ustar00rootroot00000000000000# -*- Makefile -*- # This Makefile assumes "make" has been previously run in the parent folder COQBIN?=$(dir $(shell which coqtop)) COQC := $(COQBIN)coqc PARAMLIBS := -I ../src EXAMPLES := example.v ListQueue.v features.v wadler.v bug.v bug2.v bug3.v bug4.v bug5.v dummyFix.v exmNotParametric.v all:: Parametricity.vo examples:: $(EXAMPLES:.v=.vo) ListQueue.vo: ListQueue.v Parametricity.vo example.vo: example.v Parametricity.vo features.vo: features.v Parametricity.vo wadler.vo: wadler.v Parametricity.vo bug.vo: bug.v Parametricity.vo bug%.vo: bug%.v Parametricity.vo # native eats too much memory, see eg https://gitlab.com/coq/coq/-/jobs/1144081161 %.vo: %.v $(COQC) $(PARAMLIBS) -R . "" -native-compiler no $< ide:: Parametricity.vo $(COQBIN)coqide -debug $(PARAMLIBS) $(EXAMPLES) top:: Parametricity.vo $(COQBIN)coqtop $(PARAMLIBS) clean:: rm -f *.vo *.glob *.d paramcoq-1.1.3-coq8.19/test-suite/Parametricity.v000066400000000000000000000043371454026223400215420ustar00rootroot00000000000000Declare ML Module "coq-paramcoq.plugin". Ltac destruct_reflexivity := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail end. Ltac destruct_construct x := (destruct x; [ constructor 1 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail). Ltac unfold_cofix := intros; match goal with [ |- _ = ?folded ] => let x := fresh "x" in let typ := type of folded in (match folded with _ _ => pattern folded | _ => pattern folded at 2 end); match goal with [ |- ?P ?x ] => refine (let rebuild : typ -> typ := _ in let path : rebuild folded = folded := _ in eq_rect _ P _ folded path) end; [ intro x ; destruct_construct x; fail | destruct folded; reflexivity | reflexivity]; fail end. Ltac destruct_with_nat_arg_pattern x := pattern x; match type of x with | ?I 0 => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun p => _ p | S n => fun _ => unit end q) := _ in gen 0 x) | ?I (S ?n) => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun _ => unit | S n => fun p => _ p end q) := _ in gen (S n) x) end; intros m q; destruct q. Ltac destruct_reflexivity_with_nat_arg_pattern := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail end. Global Parametricity Tactic := ((destruct_reflexivity; fail) || (unfold_cofix; fail) || (destruct_reflexivity_with_nat_arg_pattern; fail) || auto). Require Import ProofIrrelevance. (* for opaque terms *) Set Allow StrictProp. (* TODO: use SProp instead of ProofIrrelevance *) Parametricity Module Logic. Parametricity Module Datatypes. Parametricity Module Specif. Parametricity Module Decimal. Parametricity Module Hexadecimal. Parametricity Module Number. Parametricity Module Nat. Parametricity Module Peano. Parametricity Module Wf. Parametricity Module Tactics. Export Logic_R Datatypes_R Specif_R Nat_R Peano_R Wf_R Tactics_R. paramcoq-1.1.3-coq8.19/test-suite/bug.v000066400000000000000000000007701454026223400174770ustar00rootroot00000000000000Require Import Parametricity. Definition n1 := 3. Definition n2 := 2. Definition n3 := 0. Inductive I1 (p := n1) (q := n2) (n : nat) (r := n) : Type := c1. Inductive I2 : let p := n2 in Type := c2. Inductive I3 : Type := c3 : let p := n3 in I3. Inductive J : I1 n2 -> I2 -> I3 -> Type := | cj : J (c1 n2) c2 c3. Inductive K : I1 n3 -> I2 -> I3 -> Type := . Definition T := I1 n2 -> I2 -> I3. Definition C := c1. Set Parametricity Debug. Parametricity Recursive nat. Parametricity Recursive I1. paramcoq-1.1.3-coq8.19/test-suite/bug2.v000066400000000000000000000002721454026223400175560ustar00rootroot00000000000000Declare ML Module "coq-paramcoq.plugin". Definition Coq__o__Init__o__Nat__o__add_R :=0. Parametricity Recursive Nat.add. (* Error: Coq__o__Init__o__Nat__o__add_R already exists. *) paramcoq-1.1.3-coq8.19/test-suite/bug3.v000066400000000000000000001041251454026223400175610ustar00rootroot00000000000000Declare ML Module "coq-paramcoq.plugin". Require Import PeanoNat. Require Import Recdef. Set Implicit Arguments. Require Import Lia. Fixpoint subS (n m : nat) {struct n} : nat := match n return nat with | 0 => 0 (* originally n*) | S k => match m return nat with | 0 => S k (* originally n*) | S l => subS k l end end. Definition modS := fun x y : nat => match y with | 0 => match (1 mod 0) with | 0 => 0 | _ => x end | S y' => subS y' (snd (Nat.divmod x y' 0 y')) end. Lemma subS_same : forall n m, subS n m = Nat.sub n m. Proof. induction n; destruct m; simpl; auto. Defined. Lemma modS_same : forall n m, modS n m = Nat.modulo n m. Proof. destruct m; simpl; auto. rewrite subS_same. reflexivity. Defined. Function GcdS (a b : nat) {wf lt a} : nat := match a with | O => b | S k => GcdS (modS b (S k)) (S k) end. Proof. - intros m n k Heq. rewrite modS_same. simpl. lia. - exact Wf_nat.lt_wf. Defined. Ltac destruct_reflexivity := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail end. Ltac destruct_construct x := (destruct x; [ constructor 1 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail). Ltac unfold_cofix := intros; match goal with [ |- _ = ?folded ] => let x := fresh "x" in let typ := type of folded in (match folded with _ _ => pattern folded | _ => pattern folded at 2 end); match goal with [ |- ?P ?x ] => refine (let rebuild : typ -> typ := _ in let path : rebuild folded = folded := _ in eq_rect _ P _ folded path) end; [ intro x ; destruct_construct x; fail | destruct folded; reflexivity | reflexivity]; fail end. Ltac destruct_with_nat_arg_pattern x := pattern x; match type of x with | ?I 0 => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun p => _ p | S n => fun _ => unit end q) := _ in gen 0 x) | ?I (S ?n) => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun _ => unit | S n => fun p => _ p end q) := _ in gen (S n) x) end; intros m q; destruct q. Ltac destruct_reflexivity_with_nat_arg_pattern := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail end. Global Parametricity Tactic := ((destruct_reflexivity; fail) || (unfold_cofix; fail) || (destruct_reflexivity_with_nat_arg_pattern; fail) || auto). Require Import ProofIrrelevance. (* Parametricity Recursive GcdS qualified. *) (* FIXME *) (* DepRefs: nat le lt prod snd subS Init.Nat.divmod modS GcdS_F Recdef.iter and iff Basics.impl unit Init.Unconvertible Relation_Definitions.relation Morphisms.Proper RelationClasses.subrelation Morphisms.subrelation_proper eq eq_rect eq_ind eq_sym eq_ind_r PeanoNat.Nat.succ_wd_obligation_1 Nat.succ_wd Morphisms.subrelation_refl Morphisms.respectful RelationClasses.Transitive RelationClasses.transitivity Morphisms.trans_co_impl_morphism_obligation_1 Morphisms.trans_co_impl_morphism RelationClasses.Symmetric RelationClasses.Reflexive RelationClasses.Equivalence RelationClasses.Equivalence_Transitive RelationClasses.PER RelationClasses.PER_Symmetric RelationClasses.symmetry RelationClasses.PER_Transitive Morphisms.PER_morphism_obligation_1 Morphisms.PER_morphism Init.Nat.pred RelationClasses.Equivalence_Symmetric RelationClasses.Equivalence_PER Nat.pred_succ Morphisms.reflexive_proper_proxy and_rect and_ind Morphisms.iff_impl_subrelation PeanoNat.Nat.pred_wd_obligation_1 Nat.pred_wd RelationClasses.Equivalence_Reflexive Morphisms.subrelation_respectful RelationClasses.eq_Reflexive eq_trans RelationClasses.eq_Transitive RelationClasses.eq_Symmetric RelationClasses.eq_equivalence Nat.eq_equiv Nat.succ_inj Nat.succ_inj_wd Morphisms.ProperProxy Morphisms.Reflexive_partial_app_morphism False False_rect False_ind not iff_sym RelationClasses.iff_Symmetric iff_trans RelationClasses.iff_Transitive iff_refl RelationClasses.iff_Reflexive RelationClasses.iff_equivalence Morphisms.per_partial_app_morphism_obligation_1 Morphisms.per_partial_app_morphism Morphisms.trans_sym_co_inv_impl_morphism_obligation_1 Morphisms.trans_sym_co_inv_impl_morphism Basics.flip RelationClasses.reflexivity comparison Init.Nat.compare or or_ind Morphisms.trans_co_eq_inv_impl_morphism_obligation_1 Morphisms.trans_co_eq_inv_impl_morphism Morphisms.eq_proper_proxy Morphisms_Prop.or_iff_morphism_obligation_1 Morphisms_Prop.or_iff_morphism nat_rect nat_ind f_equal f_equal_nat eq_add_S True Nat.compare_eq_iff Peano.le_0_n le_ind Peano.le_pred Peano.le_S_n Peano.le_n_S Nat.compare_le_iff Nat.compare_lt_iff Nat.lt_eq_cases Nat.le_refl Morphisms.iff_flip_impl_subrelation Nat.lt_succ_r Nat.lt_succ_diag_r PeanoNat.Nat.lt_wd_obligation_1 Nat.lt_wd Nat.compare_refl Morphisms_Prop.not_iff_morphism_obligation_1 Morphisms_Prop.not_iff_morphism Nat.lt_irrefl Nat.neq_succ_diag_l Nat.lt_le_incl Nat.nlt_succ_diag_l Nat.nle_succ_diag_l Nat.bi_induction Morphisms_Prop.iff_iff_iff_impl_morphism_obligation_1 Morphisms_Prop.iff_iff_iff_impl_morphism Nat.central_induction Nat.le_wd or_iff_compat_r or_cancel_r Nat.le_succ_l Nat.succ_lt_mono lt_S_n Acc Acc_inv positive BinPosDef.Pos.succ BinPosDef.Pos.of_succ_nat Z BinIntDef.Z.of_nat Decidable.decidable Decidable.dec_not_not BinPosDef.Pos.pred_double BinIntDef.Z.pred_double BinIntDef.Z.double BinIntDef.Z.succ_double BinIntDef.Z.pos_sub BinPosDef.Pos.add BinIntDef.Z.add Morphisms.reflexive_proper Z.eq Morphisms.reflexive_eq_dom_reflexive Z.add_wd Z.eq_equiv BinIntDef.Z.succ Z.succ_wd BinIntDef.Z.pred BinIntDef.Z.opp BinPosDef.Pos.compare_cont BinPosDef.Pos.compare BinPosDef.Pos.mask BinPosDef.Pos.double_pred_mask BinPosDef.Pos.double_mask BinPosDef.Pos.succ_double_mask BinPosDef.Pos.sub_mask Pos.mask2cmp BinPosDef.Pos.pred BinPosDef.Pos.pred_mask BinPosDef.Pos.sub_mask_carry positive_rect positive_ind Pos.sub_mask_carry_spec Pos.switch_Eq Pos.compare_cont_spec Pos.compare_xI_xO Pos.compare_xO_xI Pos.compare_sub_mask BinPosDef.Pos.add_carry Pos.add_carry_spec Pos.add_comm Pos.add_1_r Pos.add_succ_r Pos.add_succ_l Pos.add_1_l Pos.add_assoc Pos.succ_pred_double Pos.add_xI_pred_double Pos.SubMaskSpec Pos.sub_mask_spec Pos.sub_mask_nul_iff Pos.compare_eq_iff Pos.eq_equiv Pos.compare_refl Pos.sub_mask_diag Pos.compare_xI_xI Pos.compare_xO_xO Pos.lt Pos.compare_lt_iff CompOpp Pos.compare_cont_antisym Pos.compare_antisym CompOpp_involutive CompOpp_inj CompOpp_iff CompareSpec Pos.compare_spec Pos.add_no_neutral Pos.sub_mask_add_diag_r ex Pos.sub_mask_neg_iff Pos.lt_iff_add Pos.succ_not_1 Pos.succ_inj Pos.add_carry_add not_eq_sym Pos.add_reg_r Pos.add_reg_l Pos.add_cancel_l Pos.sub_mask_add_diag_l Pos.sub_mask_add Pos.sub_mask_pos_iff Pos.sub_mask_pos' Pos.sub_mask_pos BinPosDef.Pos.sub Pos.sub_xI_xI Pos.sub_xI_xO Pos.sub_xO_xI Pos.sub_xO_xO Z.pos_sub_spec Z.pos_sub_diag Z.Private_BootStrap.add_opp_diag_r Z.pos_sub_opp Z.Private_BootStrap.opp_add_distr Pos.peano_rect Pos.peano_ind Pos.compare_succ_r Pos.compare_succ_l Pos.compare_succ_succ Pos.add_compare_mono_l Pos.add_compare_mono_r Pos.lt_trans Pos.add_lt_mono_l Pos.lt_succ_diag_r Pos.lt_add_r Pos.sub_add Pos.add_sub_assoc Pos.add_lt_mono_r Pos.sub_add_distr Pos.add_sub Pos.sub_sub_distr Pos.gt Pos.gt_lt_iff Pos.lt_gt Z.Private_BootStrap.pos_sub_add Z.Private_BootStrap.opp_inj Z.Private_BootStrap.add_comm Z.Private_BootStrap.add_0_r Z.Private_BootStrap.add_assoc_pos Z.Private_BootStrap.add_assoc Z.pred_succ Z.pred_wd Z.succ_inj Z.succ_inj_wd Z.add_succ_l Z.add_0_l Z.succ_pred Z.peano_ind Z.bi_induction Z.add_assoc fast_Zplus_assoc lt_n_S nat_rec gt lt_le_S gt_le_S all Morphisms.pointwise_relation Morphisms_Prop.all_iff_morphism_obligation_1 Morphisms_Prop.all_iff_morphism RelationClasses.complement RelationClasses.Irreflexive RelationClasses.StrictOrder RelationClasses.StrictOrder_Transitive Nat.lt_asymm Nat.lt_trans Nat.lt_strorder Nat.Private_OrderTac.IsTotal.lt_strorder Nat.le_lteq Nat.Private_OrderTac.IsTotal.le_lteq Nat.lt_compat Nat.Private_OrderTac.IsTotal.lt_compat OrdersTac.ord OrdersTac.trans_ord Nat.Private_OrderTac.IsTotal.eq_equiv Nat.Private_OrderTac.Tac.interp_ord Nat.Private_OrderTac.Tac.trans Nat.Private_OrderTac.Tac.lt_trans RelationClasses.StrictOrder_Irreflexive Nat.Private_OrderTac.Tac.lt_irrefl Nat.le_gt_cases Nat.lt_trichotomy Nat.lt_total Nat.Private_OrderTac.IsTotal.lt_total Nat.Private_OrderTac.Tac.not_gt_le Nat.le_le_succ_r Nat.Private_OrderTac.Tac.le_lt_trans Nat.le_succ_r Nat.lt_exists_pred_strong Nat.lt_exists_pred Nat.rs_rs' Nat.A'A_right Nat.le_ngt Nat.rbase Nat.lt_lt_succ_r Nat.rs'_rs'' Nat.strong_right_induction Nat.right_induction Nat.Private_OrderTac.Tac.lt_eq Nat.eq_le_incl Nat.pred_0 Nat.neq_succ_0 Nat.le_0_l Nat.induction Nat.lt_0_succ le_n_S sumbool sumbool_rect sumbool_rec le_lt_dec le_gt_dec Zplus_assoc_reverse fast_Zplus_assoc_reverse Nat.Private_OrderTac.Tac.not_ge_lt Nat.lt_le_trans ltof lt_n_Sm_le Nat.nlt_0_r well_founded well_founded_ltof lt_wf N BinNatDef.N.sub Init.Nat.sub BinNatDef.N.of_nat Init.Nat.add BinPosDef.Pos.iter_op BinPosDef.Pos.to_nat BinNatDef.N.to_nat BinPosDef.Pos.of_nat Pos.of_nat_succ Pos.iter_op_succ Nat.add_succ_l Nat.add_0_l PeanoNat.Nat.add_wd_obligation_1 Nat.add_wd Nat.add_assoc Pos2Nat.inj_succ Nat2Pos.id SuccNat2Pos.id_succ Nnat.Nat2N.id BinNatDef.N.compare Pos2Nat.is_succ Pos.le Pos.le_1_l Pos.lt_succ_r Pos.lt_1_succ Pos.succ_pred_or Nat.compare_succ Pos2Nat.inj_1 Nat.compare_antisym Nat.compare_gt_iff Pos2Nat.is_pos Pos2Nat.inj_compare Nnat.N2Nat.inj_compare Nnat.Nat2N.inj_compare nat_compare_le BinIntDef.Z.of_N nat_N_Z BinIntDef.Z.sub BinIntDef.Z.compare Z.compare_sub N.le N2Z.inj_compare N.compare_antisym BinIntDef.Z.max N2Z.inj_sub_max N2Z.inj_sub Nat.sub_0_r Pos.sub_mask_neg_iff' Pos.sub_mask_neg Pos2Nat.inj_add PeanoNat.Nat.sub_wd_obligation_1 Nat.sub_wd Nat.sub_succ_r Nat.sub_0_l Nat.nle_succ_0 Nat.succ_le_mono Nat.sub_succ Nat.case_analysis Nat.double_induction Nat.sub_0_le Nat.sub_diag Nat.add_succ_r Nat.add_0_r Nat.add_comm Nat.lt_ind Nat.lt_succ_l Nat.lt_ind_rel Nat.sub_gt Nat.add_pred_l Nat.add_pred_r Nat.add_sub_assoc Nat.add_sub Nat.add_sub_eq_l Pos2Nat.inj_lt Nnat.N2Nat.inj_sub Pos2Nat.id Pos2Nat.inj Nnat.N2Nat.id Nnat.N2Nat.inj Nnat.Nat2N.inj_sub Nat2Z.inj_sub BinPosDef.Pos.mul BinIntDef.Z.mul Z.mul_wd Z.Private_BootStrap.mul_1_l Pos.mul_1_r Pos.mul_xI_r Pos.mul_xO_r Pos.mul_comm Pos.mul_add_distr_l Pos.mul_add_distr_r Pos.add_lt_mono Pos.gt_lt Pos.mul_compare_mono_l Pos.mul_lt_mono_l Pos.mul_sub_distr_l Pos.mul_sub_distr_r Pos.mul_compare_mono_r Z.Private_BootStrap.mul_add_distr_pos Z.Private_BootStrap.mul_0_r Z.Private_BootStrap.mul_opp_r Z.Private_BootStrap.mul_add_distr_r Z.mul_succ_l Z.add_succ_r Z.add_0_r Z.add_comm Z.add_cancel_l Z.add_cancel_r Z.mul_0_l Z.mul_succ_r Z.one_succ Z.add_1_l Zred_factor3 fast_Zred_factor3 Z.mul_0_r Zred_factor5 fast_Zred_factor5 Z.le Z.lt Z.compare_eq_iff Z.compare_le_iff Z.compare_lt_iff Z.lt_eq_cases Z.lt_wd Z.compare_refl Z.lt_irrefl Z.sub_succ_r Z.lt_succ_r Z.lt_le_incl Z.central_induction Z.le_refl Z.lt_succ_diag_r Z.neq_succ_diag_l Z.nlt_succ_diag_l Z.nle_succ_diag_l Z.le_wd Z.le_succ_l Z.lt_asymm Z.lt_trans Z.le_trans RelationClasses.PreOrder Z.le_preorder RelationClasses.PreOrder_Reflexive Nat2Z.is_nonneg Z.mul_1_r intro_Z Z.pred_inj Z.pred_inj_wd Z.opp_wd Z.add_pred_l Z.opp_succ Z.opp_0 Z.opp_add_distr fast_Zopp_plus_distr Z.mul_add_distr_r Z.mul_comm Z.mul_add_distr_l Z.add_shuffle0 Z.add_shuffle1 Z.sub_wd Z.sub_0_r Z.add_pred_r Z.add_opp_r Z.sub_succ_l Z.sub_diag Z.add_opp_diag_l Z.add_opp_diag_r Pos2Z.opp_neg OMEGA13 fast_OMEGA13 Z.succ_lt_mono Z.succ_le_mono Z.add_le_mono_l Z.add_le_mono_r Z.opp_pred Z.opp_involutive Z.opp_sub_distr Z.sub_sub_distr Z.sub_simpl_r Z.le_0_sub Z.compare_antisym Z.ge Z.ge_le_iff Zge_left Nat.lt_nge gt_not_le not_le_minus_0 inj_minus2 Z.add_shuffle3 fast_Zplus_permute subS_same Init.Nat.modulo modS_same ge ex_ind Nat.lt_decidable dec_lt Nat.nlt_ge not_lt Z.add_le_mono Z.add_nonneg_nonneg OMEGA2 Z.gt inj_eq proj1 Nat.compare_ge_iff nat_compare_ge Nat2Z.inj_compare Nat2Z.inj_ge inj_ge nat_compare_gt Nat2Z.inj_gt inj_gt Nat2Z.inj_le inj_le Pos2Z.inj_succ Nat2Z.inj_succ Z.opp_eq_mul_m1 fast_Zopp_eq_mult_neg_1 sumbool_ind GcdS_tcc max_type max_type_rect max_type_ind max and_rec Nat.le_lt_trans sig sig_rect sig_rec GcdS_terminate GcdS nat_R is defined nat_R_rect is defined nat_R_ind is defined nat_R_rec is defined le_R is defined le_R_ind is defined Coq__o__Init__o__Peano__o__lt_R is defined 'Coq__o__Init__o__Peano__o__lt_R' is now a registered translation. prod_R is defined prod_R_rect is defined prod_R_ind is defined prod_R_rec is defined Coq__o__Init__o__Datatypes__o__snd_R is defined 'Coq__o__Init__o__Datatypes__o__snd_R' is now a registered translation. Top__o__subS_R is defined 'Top__o__subS_R' is now a registered translation. Coq__o__Init__o__Nat__o__divmod_R is defined 'Coq__o__Init__o__Nat__o__divmod_R' is now a registered translation. Top__o__modS_R is defined 'Top__o__modS_R' is now a registered translation. Top__o__GcdS_F_R is defined 'Top__o__GcdS_F_R' is now a registered translation. Coq__o__funind__o__Recdef__o__iter_R is defined 'Coq__o__funind__o__Recdef__o__iter_R' is now a registered translation. and_R is defined and_R_rect is defined and_R_ind is defined and_R_rec is defined Coq__o__Init__o__Logic__o__iff_R is defined 'Coq__o__Init__o__Logic__o__iff_R' is now a registered translation. Coq__o__Program__o__Basics__o__impl_R is defined 'Coq__o__Program__o__Basics__o__impl_R' is now a registered translation. unit_R is defined unit_R_rect is defined unit_R_ind is defined unit_R_rec is defined Coq__o__Classes__o__Init__o__Unconvertible_R is defined 'Coq__o__Classes__o__Init__o__Unconvertible_R' is now a registered translation. Coq__o__Relations__o__Relation_Definitions__o__relation_R is defined 'Coq__o__Relations__o__Relation_Definitions__o__relation_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__Proper_R is defined 'Coq__o__Classes__o__Morphisms__o__Proper_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__subrelation_R is defined 'Coq__o__Classes__o__RelationClasses__o__subrelation_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__subrelation_proper_R is defined 'Coq__o__Classes__o__Morphisms__o__subrelation_proper_R' is now a registered translation. eq_R is defined eq_R_rect is defined eq_R_ind is defined eq_R_rec is defined Coq__o__Init__o__Logic__o__eq_rect_R is defined 'Coq__o__Init__o__Logic__o__eq_rect_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_ind_R is defined 'Coq__o__Init__o__Logic__o__eq_ind_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_sym_R is defined 'Coq__o__Init__o__Logic__o__eq_sym_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_ind_r_R is defined 'Coq__o__Init__o__Logic__o__eq_ind_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_obligation_1_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_obligation_1_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__subrelation_refl_R is defined 'Coq__o__Classes__o__Morphisms__o__subrelation_refl_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__respectful_R is defined 'Coq__o__Classes__o__Morphisms__o__respectful_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Transitive_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__transitivity_R is defined 'Coq__o__Classes__o__RelationClasses__o__transitivity_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Reflexive_R' is now a registered translation. Equivalence_R is defined Coq__o__Classes__o__RelationClasses__o__Equivalence_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_Transitive_R' is now a registered translation. PER_R is defined Coq__o__Classes__o__RelationClasses__o__PER_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__PER_Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__symmetry_R is defined 'Coq__o__Classes__o__RelationClasses__o__symmetry_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__PER_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__PER_Transitive_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__PER_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__PER_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__PER_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__PER_morphism_R' is now a registered translation. Coq__o__Init__o__Nat__o__pred_R is defined 'Coq__o__Init__o__Nat__o__pred_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Equivalence_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Equivalence_PER_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_PER_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_succ_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_succ_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__reflexive_proper_proxy_R is defined 'Coq__o__Classes__o__Morphisms__o__reflexive_proper_proxy_R' is now a registered translation. Coq__o__Init__o__Logic__o__and_rect_R is defined 'Coq__o__Init__o__Logic__o__and_rect_R' is now a registered translation. Coq__o__Init__o__Logic__o__and_ind_R is defined 'Coq__o__Init__o__Logic__o__and_ind_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__iff_impl_subrelation_R is defined 'Coq__o__Classes__o__Morphisms__o__iff_impl_subrelation_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_obligation_1_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_obligation_1_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Equivalence_Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_Reflexive_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__subrelation_respectful_R is defined 'Coq__o__Classes__o__Morphisms__o__subrelation_respectful_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_Reflexive_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_trans_R is defined 'Coq__o__Init__o__Logic__o__eq_trans_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_Transitive_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_equivalence_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_equivalence_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_equiv_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_equiv_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_wd_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__ProperProxy_R is defined 'Coq__o__Classes__o__Morphisms__o__ProperProxy_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__Reflexive_partial_app_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__Reflexive_partial_app_morphism_R' is now a registered translation. False_R is defined False_R_rect is defined False_R_ind is defined False_R_rec is defined Coq__o__Init__o__Logic__o__False_rect_R is defined 'Coq__o__Init__o__Logic__o__False_rect_R' is now a registered translation. Coq__o__Init__o__Logic__o__False_ind_R is defined 'Coq__o__Init__o__Logic__o__False_ind_R' is now a registered translation. Coq__o__Init__o__Logic__o__not_R is defined 'Coq__o__Init__o__Logic__o__not_R' is now a registered translation. Coq__o__Init__o__Logic__o__iff_sym_R is defined 'Coq__o__Init__o__Logic__o__iff_sym_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_Symmetric_R' is now a registered translation. Coq__o__Init__o__Logic__o__iff_trans_R is defined 'Coq__o__Init__o__Logic__o__iff_trans_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_Transitive_R' is now a registered translation. Coq__o__Init__o__Logic__o__iff_refl_R is defined 'Coq__o__Init__o__Logic__o__iff_refl_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_Reflexive_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_equivalence_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_equivalence_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_R' is now a registered translation. Coq__o__Program__o__Basics__o__flip_R is defined 'Coq__o__Program__o__Basics__o__flip_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__reflexivity_R is defined 'Coq__o__Classes__o__RelationClasses__o__reflexivity_R' is now a registered translation. comparison_R is defined comparison_R_rect is defined comparison_R_ind is defined comparison_R_rec is defined Coq__o__Init__o__Nat__o__compare_R is defined 'Coq__o__Init__o__Nat__o__compare_R' is now a registered translation. or_R is defined or_R_ind is defined Coq__o__Init__o__Logic__o__or_ind_R is defined 'Coq__o__Init__o__Logic__o__or_ind_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__eq_proper_proxy_R is defined 'Coq__o__Classes__o__Morphisms__o__eq_proper_proxy_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_R' is now a registered translation. Coq__o__Init__o__Datatypes__o__nat_rect_R is defined 'Coq__o__Init__o__Datatypes__o__nat_rect_R' is now a registered translation. Coq__o__Init__o__Datatypes__o__nat_ind_R is defined 'Coq__o__Init__o__Datatypes__o__nat_ind_R' is now a registered translation. Coq__o__Init__o__Logic__o__f_equal_R is defined 'Coq__o__Init__o__Logic__o__f_equal_R' is now a registered translation. Coq__o__Init__o__Peano__o__f_equal_nat_R is defined 'Coq__o__Init__o__Peano__o__f_equal_nat_R' is now a registered translation. Coq__o__Init__o__Peano__o__eq_add_S_R is defined 'Coq__o__Init__o__Peano__o__eq_add_S_R' is now a registered translation. True_R is defined True_R_rect is defined True_R_ind is defined True_R_rec is defined Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_eq_iff_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_eq_iff_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_0_n_R is defined 'Coq__o__Init__o__Peano__o__le_0_n_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_ind_R is defined 'Coq__o__Init__o__Peano__o__le_ind_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_pred_R is defined 'Coq__o__Init__o__Peano__o__le_pred_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_S_n_R is defined 'Coq__o__Init__o__Peano__o__le_S_n_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_n_S_R is defined 'Coq__o__Init__o__Peano__o__le_n_S_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_le_iff_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_le_iff_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_lt_iff_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_lt_iff_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_eq_cases_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_eq_cases_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_refl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_refl_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__iff_flip_impl_subrelation_R is defined 'Coq__o__Classes__o__Morphisms__o__iff_flip_impl_subrelation_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_diag_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_diag_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_obligation_1_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_obligation_1_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_refl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_refl_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_irrefl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_irrefl_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_diag_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_diag_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_incl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_incl_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_succ_diag_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_succ_diag_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__nle_succ_diag_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__nle_succ_diag_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__bi_induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__bi_induction_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__central_induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__central_induction_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_wd_R' is now a registered translation. Coq__o__Init__o__Logic__o__or_iff_compat_r_R is defined 'Coq__o__Init__o__Logic__o__or_iff_compat_r_R' is now a registered translation. Coq__o__Init__o__Logic__o__or_cancel_r_R is defined 'Coq__o__Init__o__Logic__o__or_cancel_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_lt_mono_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_lt_mono_R' is now a registered translation. Coq__o__Arith__o__Lt__o__lt_S_n_R is defined 'Coq__o__Arith__o__Lt__o__lt_S_n_R' is now a registered translation. Acc_R is defined Acc_R_rect is defined Acc_R_ind is defined Acc_R_rec is defined Coq__o__Init__o__Wf__o__Acc_inv_R is defined 'Coq__o__Init__o__Wf__o__Acc_inv_R' is now a registered translation. positive_R is defined positive_R_rect is defined positive_R_ind is defined positive_R_rec is defined Coq__o__PArith__o__BinPosDef__o__Pos__o__succ_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__succ_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__of_succ_nat_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__of_succ_nat_R' is now a registered translation. Z_R is defined Z_R_rect is defined Z_R_ind is defined Z_R_rec is defined Coq__o__ZArith__o__BinIntDef__o__Z__o__of_nat_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__of_nat_R' is now a registered translation. Coq__o__Logic__o__Decidable__o__decidable_R is defined 'Coq__o__Logic__o__Decidable__o__decidable_R' is now a registered translation. Coq__o__Logic__o__Decidable__o__dec_not_not_R is defined 'Coq__o__Logic__o__Decidable__o__dec_not_not_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__pred_double_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__pred_double_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__pred_double_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__pred_double_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__double_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__double_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__succ_double_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__succ_double_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__pos_sub_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__pos_sub_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__add_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__add_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__add_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__add_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__reflexive_proper_R is defined 'Coq__o__Classes__o__Morphisms__o__reflexive_proper_R' is now a registered translation. Coq__o__ZArith__o__BinInt__o__Z__o__eq_R is defined 'Coq__o__ZArith__o__BinInt__o__Z__o__eq_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__reflexive_eq_dom_reflexive_R is defined 'Coq__o__Classes__o__Morphisms__o__reflexive_eq_dom_reflexive_R' is now a registered translation. Coq__o__ZArith__o__BinInt__o__Z__o__add_wd_R is defined 'Coq__o__ZArith__o__BinInt__o__Z__o__add_wd_R' is now a registered translation. Coq__o__ZArith__o__BinInt__o__Z__o__eq_equiv_R is defined 'Coq__o__ZArith__o__BinInt__o__Z__o__eq_equiv_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__succ_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__succ_R' is now a registered translation. Coq__o__ZArith__o__BinInt__o__Z__o__succ_wd_R is defined 'Coq__o__ZArith__o__BinInt__o__Z__o__succ_wd_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__pred_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__pred_R' is now a registered translation. Coq__o__ZArith__o__BinIntDef__o__Z__o__opp_R is defined 'Coq__o__ZArith__o__BinIntDef__o__Z__o__opp_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__compare_cont_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__compare_cont_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__compare_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__compare_R' is now a registered translation. mask_R is defined mask_R_rect is defined mask_R_ind is defined mask_R_rec is defined Coq__o__PArith__o__BinPosDef__o__Pos__o__double_pred_mask_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__double_pred_mask_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__double_mask_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__double_mask_R' is now a registered translation. Coq__o__PArith__o__BinPosDef__o__Pos__o__succ_double_mask_R is defined 'Coq__o__PArith__o__BinPosDef__o__Pos__o__succ_double_mask_R' is now a registered translation. Anomaly: Uncaught exception Not_found. Please report at http://coq.inria.fr/bugs/. *) paramcoq-1.1.3-coq8.19/test-suite/bug4.v000066400000000000000000000064541454026223400175700ustar00rootroot00000000000000 Declare ML Module "coq-paramcoq.plugin". Require Import PeanoNat. Require Import PArith. Print BinPosDef.Pos.sub_mask. Fixpoint sub_mask (xx yy : positive) {struct yy} : BinPosDef.Pos.mask := match xx with | (p~1)%positive => match yy with | (q~1)%positive => BinPosDef.Pos.double_mask (sub_mask p q) | (q~0)%positive => BinPosDef.Pos.succ_double_mask (sub_mask p q) | 1%positive => BinPosDef.Pos.IsPos p~0 end | (p~0)%positive => match yy with | (q~1)%positive => BinPosDef.Pos.succ_double_mask (sub_mask_carry p q) | (q~0)%positive => BinPosDef.Pos.double_mask (sub_mask p q) | 1%positive => BinPosDef.Pos.IsPos (BinPosDef.Pos.pred_double p) end | 1%positive => match yy with | (_~1)%positive => BinPosDef.Pos.IsNeg | (_~0)%positive => BinPosDef.Pos.IsNeg | 1%positive => BinPosDef.Pos.IsNul end end with sub_mask_carry (xx yy : positive) {struct yy} : BinPosDef.Pos.mask := match xx with | (p~1)%positive => match yy with | (q~1)%positive => BinPosDef.Pos.succ_double_mask (sub_mask_carry p q) | (q~0)%positive => BinPosDef.Pos.double_mask (sub_mask p q) | 1%positive => BinPosDef.Pos.IsPos (BinPosDef.Pos.pred_double p) end | (p~0)%positive => match yy with | (q~1)%positive => BinPosDef.Pos.double_mask (sub_mask_carry p q) | (q~0)%positive => BinPosDef.Pos.succ_double_mask (sub_mask_carry p q) | 1%positive => BinPosDef.Pos.double_pred_mask p end | 1%positive => BinPosDef.Pos.IsNeg end. (* Set Parametricity Debug. *) Ltac destruct_reflexivity := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail end. Ltac destruct_construct x := (destruct x; [ constructor 1 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail). Ltac unfold_cofix := intros; match goal with [ |- _ = ?folded ] => let x := fresh "x" in let typ := type of folded in (match folded with _ _ => pattern folded | _ => pattern folded at 2 end); match goal with [ |- ?P ?x ] => refine (let rebuild : typ -> typ := _ in let path : rebuild folded = folded := _ in eq_rect _ P _ folded path) end; [ intro x ; destruct_construct x; fail | destruct folded; reflexivity | reflexivity]; fail end. Ltac destruct_with_nat_arg_pattern x := pattern x; match type of x with | ?I 0 => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun p => _ p | S n => fun _ => unit end q) := _ in gen 0 x) | ?I (S ?n) => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun _ => unit | S n => fun p => _ p end q) := _ in gen (S n) x) end; intros m q; destruct q. Ltac destruct_reflexivity_with_nat_arg_pattern := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail end. Global Parametricity Tactic := ((destruct_reflexivity; fail) || (unfold_cofix; fail) || (destruct_reflexivity_with_nat_arg_pattern; fail) || auto). Parametricity Recursive sub_mask. paramcoq-1.1.3-coq8.19/test-suite/bug5.v000066400000000000000000001131441454026223400175640ustar00rootroot00000000000000Declare ML Module "coq-paramcoq.plugin". Require Import PeanoNat. Require Import Recdef. Set Implicit Arguments. Fixpoint subS (n m : nat) {struct n} : nat := match n return nat with | 0 => 0(* originally n*) | S k => match m return nat with | 0 => S k (* originally n*) | S l => subS k l end end. Definition modS := fun x y : nat => match y with | 0 => y | S y' => subS y' (snd (Nat.divmod x y' 0 y')) end. (* Lemma subS_same : forall n m, subS n m = Nat.sub n m. Proof. induction n; destruct m; simpl; auto. Qed. Lemma modS_same : forall n m, modS n m = Nat.modulo n m. Proof. destruct m; simpl; auto. rewrite subS_same. reflexivity. Qed. *) Lemma NNmod_upper_boundA : forall a b : nat, b <> 0 -> modS a b < b. Admitted. Definition T := forall a b : nat, b <> 0 -> modS a b < b. Parametricity Recursive T. Print T_R. Axiom NNmod_upper_boundA_R : (fun H H0 : forall a b : nat, b <> 0 -> modS a b < b => forall (a₁ a₂ : nat) (a_R : nat_R a₁ a₂) (b₁ b₂ : nat) (b_R : nat_R b₁ b₂) (H1 : b₁ <> 0) (H2 : b₂ <> 0), not_R (eq_R nat_R b_R nat_R_O_R) H1 H2 -> lt_R (modS_R a_R b_R) b_R (H a₁ b₁ H1) (H0 a₂ b₂ H2)) NNmod_upper_boundA NNmod_upper_boundA. Realizer NNmod_upper_boundA as NNmod_upper_boundA_RR := NNmod_upper_boundA_R. Lemma NNmod_upper_bound : forall a b : nat, b <> 0 -> modS a b < b. Proof. intros. apply NNmod_upper_boundA. assumption. Qed. Function GcdS (a b : nat) {wf lt a} : nat := match a with | O => b | S k => GcdS (modS b (S k)) (S k) end. Proof. - intros m n k Heq. apply NNmod_upper_bound. intros Hc. inversion Hc. - apply Wf_nat.lt_wf. Defined. Require Import ProofIrrelevance. Parametricity Recursive sig_rec. Ltac destruct_reflexivity := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail end. Ltac destruct_construct x := (destruct x; [ constructor 1 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail). Ltac unfold_cofix := intros; match goal with [ |- _ = ?folded ] => let x := fresh "x" in let typ := type of folded in (match folded with _ _ => pattern folded | _ => pattern folded at 2 end); match goal with [ |- ?P ?x ] => refine (let rebuild : typ -> typ := _ in let path : rebuild folded = folded := _ in eq_rect _ P _ folded path) end; [ intro x ; destruct_construct x; fail | destruct folded; reflexivity | reflexivity]; fail end. Ltac destruct_with_nat_arg_pattern x := pattern x; match type of x with | ?I 0 => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun p => _ p | S n => fun _ => unit end q) := _ in gen 0 x) | ?I (S ?n) => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun _ => unit | S n => fun p => _ p end q) := _ in gen (S n) x) end; intros m q; destruct q. Ltac destruct_reflexivity_with_nat_arg_pattern := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail end. Global Parametricity Tactic := ((destruct_reflexivity; fail) || (unfold_cofix; fail) || (destruct_reflexivity_with_nat_arg_pattern; fail) || auto). Parametricity Recursive GcdS qualified. (* 1 subgoal ______________________________________(1/1) forall (a₁ a₂ : nat) (a_R : nat_R a₁ a₂) (b₁ b₂ : nat) (b_R : nat_R b₁ b₂), sig_R nat_R (fun (v₁ v₂ : nat) (v_R : nat_R v₁ v₂) => ex_R nat_R (fun (p₁ p₂ : nat) (p_R : nat_R p₁ p₂) (H : forall k : nat, p₁ < k -> forall def : nat -> nat -> nat, iter (nat -> nat -> nat) k GcdS_F def a₁ b₁ = v₁) (H0 : forall k : nat, p₂ < k -> forall def : nat -> nat -> nat, iter (nat -> nat -> nat) k GcdS_F def a₂ b₂ = v₂) => forall (k₁ k₂ : nat) (k_R : nat_R k₁ k₂) (H1 : p₁ < k₁) (H2 : p₂ < k₂), Coq__o__Init__o__Peano__o__lt_R p_R k_R H1 H2 -> forall (def₁ def₂ : nat -> nat -> nat) (def_R : forall a₁0 a₂0 : nat, nat_R a₁0 a₂0 -> forall b₁0 b₂0 : nat, nat_R b₁0 b₂0 -> nat_R (def₁ a₁0 b₁0) (def₂ a₂0 b₂0)), eq_R nat_R (Coq__o__funind__o__Recdef__o__iter_R (fun H3 H4 : nat -> nat -> nat => forall a₁0 a₂0 : nat, nat_R a₁0 a₂0 -> forall b₁0 b₂0 : nat, nat_R b₁0 b₂0 -> nat_R (H3 a₁0 b₁0) (H4 a₂0 b₂0)) k_R GcdS_F GcdS_F Top__o__GcdS_F_R def₁ def₂ def_R a₁ a₂ a_R b₁ b₂ b_R) v_R (H k₁ H1 def₁) (H0 k₂ H2 def₂))) (GcdS_terminate a₁ b₁) (GcdS_terminate a₂ b₂) *) (* DepRefs: GcdS_F iter and iff Basics.impl unit Init.Unconvertible Relation_Definitions.relation Morphisms.Proper RelationClasses.subrelation Morphisms.subrelation_proper eq_rect eq_ind eq_sym eq_ind_r PeanoNat.Nat.succ_wd_obligation_1 PeanoNat.Nat.succ_wd Morphisms.subrelation_refl Morphisms.respectful RelationClasses.Transitive RelationClasses.transitivity Morphisms.trans_co_impl_morphism_obligation_1 Morphisms.trans_co_impl_morphism RelationClasses.Symmetric RelationClasses.Reflexive RelationClasses.Equivalence RelationClasses.Equivalence_Transitive RelationClasses.PER RelationClasses.PER_Symmetric RelationClasses.symmetry RelationClasses.PER_Transitive Morphisms.PER_morphism_obligation_1 Morphisms.PER_morphism Init.Nat.pred RelationClasses.Equivalence_Symmetric RelationClasses.Equivalence_PER PeanoNat.Nat.pred_succ Morphisms.reflexive_proper_proxy and_rect and_ind Morphisms.iff_impl_subrelation PeanoNat.Nat.pred_wd_obligation_1 PeanoNat.Nat.pred_wd RelationClasses.Equivalence_Reflexive Morphisms.subrelation_respectful RelationClasses.eq_Reflexive eq_trans RelationClasses.eq_Transitive RelationClasses.eq_Symmetric RelationClasses.eq_equivalence PeanoNat.Nat.eq_equiv PeanoNat.Nat.succ_inj PeanoNat.Nat.succ_inj_wd Morphisms.ProperProxy Morphisms.Reflexive_partial_app_morphism False_rect False_ind iff_sym RelationClasses.iff_Symmetric iff_trans RelationClasses.iff_Transitive iff_refl RelationClasses.iff_Reflexive RelationClasses.iff_equivalence Morphisms.per_partial_app_morphism_obligation_1 Morphisms.per_partial_app_morphism Morphisms.trans_sym_co_inv_impl_morphism_obligation_1 Morphisms.trans_sym_co_inv_impl_morphism Basics.flip RelationClasses.reflexivity comparison Init.Nat.compare or or_ind Morphisms.trans_co_eq_inv_impl_morphism_obligation_1 Morphisms.trans_co_eq_inv_impl_morphism Morphisms.eq_proper_proxy Morphisms_Prop.or_iff_morphism_obligation_1 Morphisms_Prop.or_iff_morphism nat_rect nat_ind f_equal f_equal_nat eq_add_S True PeanoNat.Nat.compare_eq_iff le_0_n le_ind le_pred le_S_n le_n_S PeanoNat.Nat.compare_le_iff PeanoNat.Nat.compare_lt_iff PeanoNat.Nat.lt_eq_cases PeanoNat.Nat.le_refl Morphisms.iff_flip_impl_subrelation PeanoNat.Nat.lt_succ_r PeanoNat.Nat.lt_succ_diag_r PeanoNat.Nat.lt_wd_obligation_1 PeanoNat.Nat.lt_wd PeanoNat.Nat.compare_refl Morphisms_Prop.not_iff_morphism_obligation_1 Morphisms_Prop.not_iff_morphism PeanoNat.Nat.lt_irrefl PeanoNat.Nat.neq_succ_diag_l PeanoNat.Nat.lt_le_incl PeanoNat.Nat.nlt_succ_diag_l PeanoNat.Nat.nle_succ_diag_l PeanoNat.Nat.bi_induction Morphisms_Prop.iff_iff_iff_impl_morphism_obligation_1 Morphisms_Prop.iff_iff_iff_impl_morphism PeanoNat.Nat.central_induction PeanoNat.Nat.le_wd or_iff_compat_r or_cancel_r PeanoNat.Nat.le_succ_l PeanoNat.Nat.succ_lt_mono Lt.lt_S_n Acc Acc_inv RelationClasses.complement RelationClasses.Irreflexive RelationClasses.StrictOrder RelationClasses.StrictOrder_Transitive PeanoNat.Nat.lt_asymm PeanoNat.Nat.lt_trans PeanoNat.Nat.lt_strorder PeanoNat.Nat.Private_OrderTac.IsTotal.lt_strorder PeanoNat.Nat.le_lteq PeanoNat.Nat.Private_OrderTac.IsTotal.le_lteq PeanoNat.Nat.lt_compat PeanoNat.Nat.Private_OrderTac.IsTotal.lt_compat OrdersTac.ord OrdersTac.trans_ord PeanoNat.Nat.Private_OrderTac.IsTotal.eq_equiv PeanoNat.Nat.Private_OrderTac.Tac.interp_ord PeanoNat.Nat.Private_OrderTac.Tac.trans PeanoNat.Nat.Private_OrderTac.Tac.le_lt_trans RelationClasses.StrictOrder_Irreflexive PeanoNat.Nat.Private_OrderTac.Tac.lt_irrefl PeanoNat.Nat.le_gt_cases PeanoNat.Nat.lt_trichotomy PeanoNat.Nat.lt_total PeanoNat.Nat.Private_OrderTac.IsTotal.lt_total PeanoNat.Nat.Private_OrderTac.Tac.not_ge_lt PeanoNat.Nat.lt_le_trans Wf_nat.ltof Lt.lt_n_Sm_le PeanoNat.Nat.Private_OrderTac.Tac.lt_eq PeanoNat.Nat.Private_OrderTac.Tac.not_gt_le PeanoNat.Nat.eq_le_incl PeanoNat.Nat.Private_OrderTac.Tac.lt_trans PeanoNat.Nat.le_le_succ_r PeanoNat.Nat.le_succ_r PeanoNat.Nat.pred_0 PeanoNat.Nat.neq_succ_0 PeanoNat.Nat.le_0_l PeanoNat.Nat.le_ngt PeanoNat.Nat.nlt_0_r well_founded Wf_nat.well_founded_ltof Wf_nat.lt_wf NNmod_upper_bound GcdS_tcc max_type max_type_rect max_type_ind ex ex_ind Lt.lt_n_S nat_rec gt Lt.lt_le_S Gt.gt_le_S all Morphisms.pointwise_relation Morphisms_Prop.all_iff_morphism_obligation_1 Morphisms_Prop.all_iff_morphism PeanoNat.Nat.lt_exists_pred_strong PeanoNat.Nat.lt_exists_pred PeanoNat.Nat.rs_rs' PeanoNat.Nat.A'A_right PeanoNat.Nat.rbase PeanoNat.Nat.lt_lt_succ_r PeanoNat.Nat.rs'_rs'' PeanoNat.Nat.strong_right_induction PeanoNat.Nat.right_induction PeanoNat.Nat.induction PeanoNat.Nat.lt_0_succ Le.le_n_S sumbool sumbool_rect sumbool_rec Compare_dec.le_lt_dec Compare_dec.le_gt_dec max and_rec PeanoNat.Nat.le_lt_trans GcdS_terminate GcdS Top__o__GcdS_F_R is defined 'Top__o__GcdS_F_R' is now a registered translation. Coq__o__funind__o__Recdef__o__iter_R is defined 'Coq__o__funind__o__Recdef__o__iter_R' is now a registered translation. and_R is defined and_R_rect is defined and_R_ind is defined and_R_rec is defined Coq__o__Init__o__Logic__o__iff_R is defined 'Coq__o__Init__o__Logic__o__iff_R' is now a registered translation. Coq__o__Program__o__Basics__o__impl_R is defined 'Coq__o__Program__o__Basics__o__impl_R' is now a registered translation. unit_R is defined unit_R_rect is defined unit_R_ind is defined unit_R_rec is defined Coq__o__Classes__o__Init__o__Unconvertible_R is defined 'Coq__o__Classes__o__Init__o__Unconvertible_R' is now a registered translation. Coq__o__Relations__o__Relation_Definitions__o__relation_R is defined 'Coq__o__Relations__o__Relation_Definitions__o__relation_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__Proper_R is defined 'Coq__o__Classes__o__Morphisms__o__Proper_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__subrelation_R is defined 'Coq__o__Classes__o__RelationClasses__o__subrelation_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__subrelation_proper_R is defined 'Coq__o__Classes__o__Morphisms__o__subrelation_proper_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_rect_R is defined 'Coq__o__Init__o__Logic__o__eq_rect_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_ind_R is defined 'Coq__o__Init__o__Logic__o__eq_ind_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_sym_R is defined 'Coq__o__Init__o__Logic__o__eq_sym_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_ind_r_R is defined 'Coq__o__Init__o__Logic__o__eq_ind_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_obligation_1_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_obligation_1_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_wd_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__subrelation_refl_R is defined 'Coq__o__Classes__o__Morphisms__o__subrelation_refl_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__respectful_R is defined 'Coq__o__Classes__o__Morphisms__o__respectful_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Transitive_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__transitivity_R is defined 'Coq__o__Classes__o__RelationClasses__o__transitivity_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_impl_morphism_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Reflexive_R' is now a registered translation. Equivalence_R is defined Coq__o__Classes__o__RelationClasses__o__Equivalence_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_Transitive_R' is now a registered translation. PER_R is defined Coq__o__Classes__o__RelationClasses__o__PER_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__PER_Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__symmetry_R is defined 'Coq__o__Classes__o__RelationClasses__o__symmetry_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__PER_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__PER_Transitive_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__PER_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__PER_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__PER_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__PER_morphism_R' is now a registered translation. Coq__o__Init__o__Nat__o__pred_R is defined 'Coq__o__Init__o__Nat__o__pred_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Equivalence_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Equivalence_PER_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_PER_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_succ_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_succ_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__reflexive_proper_proxy_R is defined 'Coq__o__Classes__o__Morphisms__o__reflexive_proper_proxy_R' is now a registered translation. Coq__o__Init__o__Logic__o__and_rect_R is defined 'Coq__o__Init__o__Logic__o__and_rect_R' is now a registered translation. Coq__o__Init__o__Logic__o__and_ind_R is defined 'Coq__o__Init__o__Logic__o__and_ind_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__iff_impl_subrelation_R is defined 'Coq__o__Classes__o__Morphisms__o__iff_impl_subrelation_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_obligation_1_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_obligation_1_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_wd_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Equivalence_Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Equivalence_Reflexive_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__subrelation_respectful_R is defined 'Coq__o__Classes__o__Morphisms__o__subrelation_respectful_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_Reflexive_R' is now a registered translation. Coq__o__Init__o__Logic__o__eq_trans_R is defined 'Coq__o__Init__o__Logic__o__eq_trans_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_Transitive_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_Symmetric_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__eq_equivalence_R is defined 'Coq__o__Classes__o__RelationClasses__o__eq_equivalence_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_equiv_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_equiv_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_inj_wd_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__ProperProxy_R is defined 'Coq__o__Classes__o__Morphisms__o__ProperProxy_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__Reflexive_partial_app_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__Reflexive_partial_app_morphism_R' is now a registered translation. Coq__o__Init__o__Logic__o__False_rect_R is defined 'Coq__o__Init__o__Logic__o__False_rect_R' is now a registered translation. Coq__o__Init__o__Logic__o__False_ind_R is defined 'Coq__o__Init__o__Logic__o__False_ind_R' is now a registered translation. Coq__o__Init__o__Logic__o__iff_sym_R is defined 'Coq__o__Init__o__Logic__o__iff_sym_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_Symmetric_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_Symmetric_R' is now a registered translation. Coq__o__Init__o__Logic__o__iff_trans_R is defined 'Coq__o__Init__o__Logic__o__iff_trans_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_Transitive_R' is now a registered translation. Coq__o__Init__o__Logic__o__iff_refl_R is defined 'Coq__o__Init__o__Logic__o__iff_refl_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_Reflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_Reflexive_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__iff_equivalence_R is defined 'Coq__o__Classes__o__RelationClasses__o__iff_equivalence_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__per_partial_app_morphism_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_sym_co_inv_impl_morphism_R' is now a registered translation. Coq__o__Program__o__Basics__o__flip_R is defined 'Coq__o__Program__o__Basics__o__flip_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__reflexivity_R is defined 'Coq__o__Classes__o__RelationClasses__o__reflexivity_R' is now a registered translation. comparison_R is defined comparison_R_rect is defined comparison_R_ind is defined comparison_R_rec is defined Coq__o__Init__o__Nat__o__compare_R is defined 'Coq__o__Init__o__Nat__o__compare_R' is now a registered translation. or_R is defined or_R_ind is defined Coq__o__Init__o__Logic__o__or_ind_R is defined 'Coq__o__Init__o__Logic__o__or_ind_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms__o__trans_co_eq_inv_impl_morphism_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__eq_proper_proxy_R is defined 'Coq__o__Classes__o__Morphisms__o__eq_proper_proxy_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__or_iff_morphism_R' is now a registered translation. Coq__o__Init__o__Datatypes__o__nat_rect_R is defined 'Coq__o__Init__o__Datatypes__o__nat_rect_R' is now a registered translation. Coq__o__Init__o__Datatypes__o__nat_ind_R is defined 'Coq__o__Init__o__Datatypes__o__nat_ind_R' is now a registered translation. Coq__o__Init__o__Logic__o__f_equal_R is defined 'Coq__o__Init__o__Logic__o__f_equal_R' is now a registered translation. Coq__o__Init__o__Peano__o__f_equal_nat_R is defined 'Coq__o__Init__o__Peano__o__f_equal_nat_R' is now a registered translation. Coq__o__Init__o__Peano__o__eq_add_S_R is defined 'Coq__o__Init__o__Peano__o__eq_add_S_R' is now a registered translation. True_R is defined True_R_rect is defined True_R_ind is defined True_R_rec is defined Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_eq_iff_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_eq_iff_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_0_n_R is defined 'Coq__o__Init__o__Peano__o__le_0_n_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_ind_R is defined 'Coq__o__Init__o__Peano__o__le_ind_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_pred_R is defined 'Coq__o__Init__o__Peano__o__le_pred_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_S_n_R is defined 'Coq__o__Init__o__Peano__o__le_S_n_R' is now a registered translation. Coq__o__Init__o__Peano__o__le_n_S_R is defined 'Coq__o__Init__o__Peano__o__le_n_S_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_le_iff_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_le_iff_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_lt_iff_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_lt_iff_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_eq_cases_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_eq_cases_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_refl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_refl_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__iff_flip_impl_subrelation_R is defined 'Coq__o__Classes__o__Morphisms__o__iff_flip_impl_subrelation_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_diag_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_succ_diag_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_obligation_1_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_obligation_1_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_wd_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_refl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__compare_refl_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__not_iff_morphism_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_irrefl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_irrefl_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_diag_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_diag_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_incl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_incl_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_succ_diag_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_succ_diag_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__nle_succ_diag_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__nle_succ_diag_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__bi_induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__bi_induction_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__iff_iff_iff_impl_morphism_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__central_induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__central_induction_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_wd_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_wd_R' is now a registered translation. Coq__o__Init__o__Logic__o__or_iff_compat_r_R is defined 'Coq__o__Init__o__Logic__o__or_iff_compat_r_R' is now a registered translation. Coq__o__Init__o__Logic__o__or_cancel_r_R is defined 'Coq__o__Init__o__Logic__o__or_cancel_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_lt_mono_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__succ_lt_mono_R' is now a registered translation. Coq__o__Arith__o__Lt__o__lt_S_n_R is defined 'Coq__o__Arith__o__Lt__o__lt_S_n_R' is now a registered translation. Acc_R is defined Acc_R_rect is defined Acc_R_ind is defined Acc_R_rec is defined Coq__o__Init__o__Wf__o__Acc_inv_R is defined 'Coq__o__Init__o__Wf__o__Acc_inv_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__complement_R is defined 'Coq__o__Classes__o__RelationClasses__o__complement_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__Irreflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__Irreflexive_R' is now a registered translation. StrictOrder_R is defined Coq__o__Classes__o__RelationClasses__o__StrictOrder_Transitive_R is defined 'Coq__o__Classes__o__RelationClasses__o__StrictOrder_Transitive_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_asymm_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_asymm_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trans_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trans_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_strorder_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_strorder_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_strorder_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_strorder_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lteq_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lteq_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__le_lteq_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__le_lteq_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_compat_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_compat_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_compat_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_compat_R' is now a registered translation. ord_R is defined ord_R_rect is defined ord_R_ind is defined ord_R_rec is defined Coq__o__Structures__o__OrdersTac__o__trans_ord_R is defined 'Coq__o__Structures__o__OrdersTac__o__trans_ord_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__eq_equiv_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__eq_equiv_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__interp_ord_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__interp_ord_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__trans_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__trans_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__le_lt_trans_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__le_lt_trans_R' is now a registered translation. Coq__o__Classes__o__RelationClasses__o__StrictOrder_Irreflexive_R is defined 'Coq__o__Classes__o__RelationClasses__o__StrictOrder_Irreflexive_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_irrefl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_irrefl_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_gt_cases_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_gt_cases_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trichotomy_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_trichotomy_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_total_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_total_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_total_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__IsTotal__o__lt_total_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_ge_lt_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_ge_lt_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_trans_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_le_trans_R' is now a registered translation. Coq__o__Arith__o__Wf_nat__o__ltof_R is defined 'Coq__o__Arith__o__Wf_nat__o__ltof_R' is now a registered translation. Coq__o__Arith__o__Lt__o__lt_n_Sm_le_R is defined 'Coq__o__Arith__o__Lt__o__lt_n_Sm_le_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_eq_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_eq_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_gt_le_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__not_gt_le_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_le_incl_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__eq_le_incl_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_trans_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__Private_OrderTac__o__Tac__o__lt_trans_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_le_succ_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_le_succ_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_succ_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_0_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__pred_0_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_0_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__neq_succ_0_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_0_l_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_0_l_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_ngt_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_ngt_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_0_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__nlt_0_r_R' is now a registered translation. Coq__o__Init__o__Wf__o__well_founded_R is defined 'Coq__o__Init__o__Wf__o__well_founded_R' is now a registered translation. Coq__o__Arith__o__Wf_nat__o__well_founded_ltof_R is defined 'Coq__o__Arith__o__Wf_nat__o__well_founded_ltof_R' is now a registered translation. Coq__o__Arith__o__Wf_nat__o__lt_wf_R is defined 'Coq__o__Arith__o__Wf_nat__o__lt_wf_R' is now a registered translation. Top__o__NNmod_upper_bound_R is defined 'Top__o__NNmod_upper_bound_R' is now a registered translation. Top__o__GcdS_tcc_R is defined 'Top__o__GcdS_tcc_R' is now a registered translation. max_type_R is defined max_type_R_rect is defined max_type_R_ind is defined max_type_R_rec is defined Coq__o__funind__o__Recdef__o__max_type_rect_R is defined 'Coq__o__funind__o__Recdef__o__max_type_rect_R' is now a registered translation. Coq__o__funind__o__Recdef__o__max_type_ind_R is defined 'Coq__o__funind__o__Recdef__o__max_type_ind_R' is now a registered translation. ex_R is defined ex_R_ind is defined Coq__o__Init__o__Logic__o__ex_ind_R is defined 'Coq__o__Init__o__Logic__o__ex_ind_R' is now a registered translation. Coq__o__Arith__o__Lt__o__lt_n_S_R is defined 'Coq__o__Arith__o__Lt__o__lt_n_S_R' is now a registered translation. Coq__o__Init__o__Datatypes__o__nat_rec_R is defined 'Coq__o__Init__o__Datatypes__o__nat_rec_R' is now a registered translation. Coq__o__Init__o__Peano__o__gt_R is defined 'Coq__o__Init__o__Peano__o__gt_R' is now a registered translation. Coq__o__Arith__o__Lt__o__lt_le_S_R is defined 'Coq__o__Arith__o__Lt__o__lt_le_S_R' is now a registered translation. Coq__o__Arith__o__Gt__o__gt_le_S_R is defined 'Coq__o__Arith__o__Gt__o__gt_le_S_R' is now a registered translation. Coq__o__Init__o__Logic__o__all_R is defined 'Coq__o__Init__o__Logic__o__all_R' is now a registered translation. Coq__o__Classes__o__Morphisms__o__pointwise_relation_R is defined 'Coq__o__Classes__o__Morphisms__o__pointwise_relation_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_obligation_1_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_obligation_1_R' is now a registered translation. Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_R is defined 'Coq__o__Classes__o__Morphisms_Prop__o__all_iff_morphism_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_strong_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_strong_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_exists_pred_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__rs_rs'_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__rs_rs'_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__A'A_right_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__A'A_right_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__rbase_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__rbase_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_lt_succ_r_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_lt_succ_r_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__rs'_rs''_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__rs'_rs''_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__strong_right_induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__strong_right_induction_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__right_induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__right_induction_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__induction_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__induction_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_0_succ_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__lt_0_succ_R' is now a registered translation. Coq__o__Arith__o__Le__o__le_n_S_R is defined 'Coq__o__Arith__o__Le__o__le_n_S_R' is now a registered translation. sumbool_R is defined sumbool_R_rect is defined sumbool_R_ind is defined sumbool_R_rec is defined Coq__o__Init__o__Specif__o__sumbool_rect_R is defined 'Coq__o__Init__o__Specif__o__sumbool_rect_R' is now a registered translation. Coq__o__Init__o__Specif__o__sumbool_rec_R is defined 'Coq__o__Init__o__Specif__o__sumbool_rec_R' is now a registered translation. Coq__o__Arith__o__Compare_dec__o__le_lt_dec_R is defined 'Coq__o__Arith__o__Compare_dec__o__le_lt_dec_R' is now a registered translation. Coq__o__Arith__o__Compare_dec__o__le_gt_dec_R is defined 'Coq__o__Arith__o__Compare_dec__o__le_gt_dec_R' is now a registered translation. Coq__o__funind__o__Recdef__o__max_R is defined 'Coq__o__funind__o__Recdef__o__max_R' is now a registered translation. Coq__o__Init__o__Logic__o__and_rec_R is defined 'Coq__o__Init__o__Logic__o__and_rec_R' is now a registered translation. Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lt_trans_R is defined 'Coq__o__Arith__o__PeanoNat__o__Nat__o__le_lt_trans_R' is now a registered translation. Anomaly: Uncaught exception Not_found. Please report at http://coq.inria.fr/bugs/. *) paramcoq-1.1.3-coq8.19/test-suite/dummyFix.v000066400000000000000000000031031454026223400205150ustar00rootroot00000000000000 (* the only way to compute zero is for p to become canonical. The only canonical member of A=A is eq_refl. However, it is impossible to that p is propositionally equal to eq_refl. In particular the univalence axiom allows for non-refl proofs. *) Fixpoint zero (A : Set) (p : A = A) {struct p} : nat := 0. (* although this axiom breaks canonicity, it is believed to be consistent *) Axiom strong_exm : Set -> nat. Axiom strong_exm_true : strong_exm True = 0. Axiom strong_exm_false : strong_exm False = 1. (* same type as [zero] above, but provably non parametric *) Definition nonParam (A : Set) (p : A = A) : nat := strong_exm A. (* because zero cannot be unfolded, it seems safe to assume the following *) Axiom zeroOpaque :(forall x, zero x = nonParam x). Inductive eq_R (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (x₁ : A₁) (x₂ : A₂) (x_R : A_R x₁ x₂) : forall (H : A₁) (H0 : A₂), A_R H H0 -> x₁ = H -> x₂ = H0 -> Prop := eq_refl_R : eq_R A₁ A₂ A_R x₁ x₂ x_R x₁ x₂ x_R eq_refl eq_refl. Lemma zero_not_parametric : (forall (A₁ A₂ : Set) (A_R : A₁ -> A₂ -> Set) (p₁ : A₁ = A₁) (p₂ : A₂ = A₂), eq_R Set Set (fun H1 H2 : Set => H1 -> H2 -> Set) A₁ A₂ A_R A₁ A₂ A_R p₁ p₂ -> (zero A₁ p₁) = (zero A₂ p₂)) -> False. Proof using. intros Hc. specialize (Hc True False (fun _ _ => True) eq_refl eq_refl). do 2 rewrite zeroOpaque in Hc. unfold nonParam in Hc. simpl in Hc. rewrite strong_exm_true in Hc. rewrite strong_exm_false in Hc. specialize (Hc (@eq_refl_R _ _ _ _ _ _)). discriminate. Qed. paramcoq-1.1.3-coq8.19/test-suite/example.v000066400000000000000000000106731454026223400203600ustar00rootroot00000000000000Require Import Parametricity. (** Base Types. **) Inductive bool := true | false. Parametricity bool arity 1. Print bool_P. Definition boolfun := bool -> bool. Parametricity boolfun arity 1. Print boolfun_P. Definition myneg (b : bool) := match b with | true => false | false => true end. Parametricity myneg arity 1. Print myneg_P. Parametricity Recursive bool. (* Prints: Inductive bool_R : bool -> bool -> Set := true_R : bool_R true true | false_R : bool_R false false *) Lemma bool_R_eq: forall x y, bool_R x y -> x = y. intros x y H. destruct H. * reflexivity. * reflexivity. Defined. Lemma bool_R_refl: forall x, bool_R x x. induction x. constructor. constructor. Defined. (** Boolean functions **) Parametricity Recursive boolfun. Print boolfun_R. (* Prints: boolfun_R = fun f1 f2 : bool -> bool => forall x1 x2 : bool, bool_R x1 x2 -> bool_R (f1 x1) (f2 x2) *) Definition negb (x : bool) := match x with | true => false | false => true end. Parametricity negb. Check negb_R. Print negb_R. (** Universes **) Parametricity Translation Type as Type_R. Print Type_R. (* Prints : Type_R = fun A1 A2 : Type => A1 -> A2 -> Type *) Check (bool_R : Type_R bool bool). Check (boolfun_R : Type_R boolfun boolfun). Polymorphic Definition pType := Type. Parametricity pType. Check (pType_R : pType_R pType pType). (** Simple arrows **) Definition arrow (A : Type) (B : Type) := A -> B. Parametricity arrow. Print arrow_R. (* Prints: arrow_R = fun (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (B₁ B₂ : Type) (B_R : B₁ -> B₂ -> Type) (f₁ : A₁ -> B₁) (f₂ : A₂ -> B₂) => forall (x₁ : A₁) (x₂ : A₂), A_R x₁ x₂ -> B_R (f₁ x₁) (f₂ x₂) *) (** Lambdas **) Definition lambda (A : Type) (B : Type) (f : arrow A B) := fun x => f x. Parametricity lambda. Print lambda_R. (* lambda_R = fun (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (B₁ B₂ : Type) (B_R : B₁ -> B₂ -> Type) (f₁ : arrow A₁ B₁) (f₂ : arrow A₂ B₂) (f_R : arrow_R A₁ A₂ A_R B₁ B₂ B_R f₁ f₂) (x₁ : A₁) (x₂ : A₂) (x_R : A_R x₁ x₂) => f_R x₁ x₂ x_R *) (** Applications of functions *) Definition application A B (f : arrow A B) (x : A) : B := f x. Parametricity application. Print application_R. (* Prints : fun (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (B₁ B₂ : Type) (B_R : B₁ -> B₂ -> Type) (f₁ : arrow A₁ B₁) (f₂ : arrow A₂ B₂) (f_R : arrow_R A₁ A₂ A_R B₁ B₂ B_R f₁ f₂) (x₁ : A₁) (x₂ : A₂) (x_R : A_R x₁ x₂) => f_R x₁ x₂ x_R. *) (** Dependent product **) Definition for_all (A : Type) (B : A -> Type) := forall x, B x. Parametricity for_all. Print for_all_R. (* Prints: for_all_R = fun (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) (B₁ : A₁ -> Type) (B₂ : A₂ -> Type) (B_R : forall (x₁ : A₁) (x₂ : A₂), A_R x₁ x₂ -> B₁ x₁ -> B₂ x₂ -> Type) (f₁ : forall x : A₁, B₁ x) (f₂ : forall x : A₂, B₂ x) => for all (x₁ : A₁) (x₂ : A₂) (x_R : A_R x₁ x₂), B_R x₁ x₂ x_R (f₁ x₁) (f₂ x₂) *) (** Inductive types. *) Inductive nat := | O : nat | S : nat -> nat. Parametricity nat. Print nat_R. (* Prints: Inductive nat_R : nat -> nat -> Set := O_R : nat_R 0 0 | S_R : forall n₁ n₂ : nat, nat_R n₁ n₂ -> nat_R (S n₁) (S n₂) *) Inductive list (A : Type) : Type := nil : list A | cons : A -> list A -> list A. Parametricity list. Print list_R. (* Prints : Inductive list_R (A₁ A₂ : Type) (A_R : A₁ -> A₂ -> Type) : list A₁ -> list A₂ -> Type := nil_R : list_R A₁ A₂ A_R (nil A₁) (nil A₂) | cons_R : forall (x₁ : A₁) (x₂ : A₂), A_R x₁ x₂ -> forall (l₁ : list A₁) (l₂ : list A₂), list_R A₁ A₂ A_R l₁ l₂ -> list_R A₁ A₂ A_R (cons A₁ x₁ l₁) (cons A₂ x₂ l₂) *) Fixpoint length A (l : list A) : nat := match l with nil _ => O | cons _ _ tl => S (length A tl) end. Parametricity length. Check length_R. Print length_R. (* Prints : ... something that looks complicated. *) Parametricity list_rec. Print list_rec_R. Definition length2 (A : Type) (l : list A) : nat := list_rec A (fun _ => nat) O (fun _ _ => S) l. Parametricity length2. Check length2_R. Print length2_R. Print sum_rect. Parametricity Recursive sum_rect. Check sum_rect. Check sum_rect_R. paramcoq-1.1.3-coq8.19/test-suite/exmNotParametric.v000066400000000000000000000020641454026223400222020ustar00rootroot00000000000000Require Import Coq.Logic.ClassicalFacts. Inductive False_R : False -> False -> Prop :=. Inductive or_R (A₁ A₂ : Prop) (A_R : A₁ -> A₂ -> Prop) (B₁ B₂ : Prop) (B_R : B₁ -> B₂ -> Prop) : A₁ \/ B₁ -> A₂ \/ B₂ -> Prop := or_R_or_introl_R : forall (H : A₁) (H0 : A₂), A_R H H0 -> or_R A₁ A₂ A_R B₁ B₂ B_R (or_introl H) (or_introl H0) | or_R_or_intror_R : forall (H : B₁) (H0 : B₂), B_R H H0 -> or_R A₁ A₂ A_R B₁ B₂ B_R (or_intror H) (or_intror H0). Definition not_R := fun (A₁ A₂ : Prop) (A_R : A₁ -> A₂ -> Prop) (H : A₁ -> False) (H0 : A₂ -> False) => forall (H1 : A₁) (H2 : A₂), A_R H1 H2 -> False_R (H H1) (H0 H2). Lemma exmNotParam (exm : excluded_middle): (forall (A₁ A₂ : Prop) (A_R : A₁ -> A₂ -> Prop), or_R A₁ A₂ A_R (~ A₁) (~ A₂) (not_R A₁ A₂ A_R) (exm A₁) (exm A₂)) -> False. Proof using. intros Hc. specialize (Hc True False (fun _ _ => True)). destruct Hc; auto. Qed. paramcoq-1.1.3-coq8.19/test-suite/features.v000066400000000000000000000025331454026223400205370ustar00rootroot00000000000000Require Import Parametricity. (** Separate compilation: *) Parametricity nat as test. Require List. Parametricity Recursive List.rev. Check rev_R. (** Module translation *) Module A. Definition t := nat. Module B. Definition t := nat -> nat. End B. End A. Parametricity Recursive bool. Parametricity Module A. Print Module A_R. Print Module A_R.B_R. (* Parametricity Module Bool. *) (* Print Module Bool_R. *) (** Unary parametricity *) Parametricity Translation (forall X, X -> X) as ID_R arity 1. Lemma ID_unique: forall f, ID_R f -> forall A x, f A x = x. intros f f_R A x. specialize (f_R A (fun y => y = x) x). apply f_R. reflexivity. Defined. Parametricity nat arity 10. Print nat_R_10. Set Universe Polymorphism. (** Realizing axioms and section variables. *) Section Test. Variable A : Set. Variable R : A -> A -> Set. Realizer A as A_R := R. Definition id : A -> A := fun x => x. Parametricity id. End Test. (** Opaque terms. **) Require ProofIrrelevance. Lemma opaque : True. trivial. Qed. Parametricity Recursive opaque. Eval compute in opaque. Eval compute in opaque_R. Lemma opaqueunit : unit. exact tt. Qed. (* Fail Parametricity Recursive opaqueunit. DepRefs: opaqueunit Vernac Interpreter Executing command Anomaly: Uncaught exception Not_found. Please report at destruct opaqueunit. reflexivity. Parametricity Done. *) paramcoq-1.1.3-coq8.19/test-suite/stdlib_R/000077500000000000000000000000001454026223400202715ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/test-suite/stdlib_R/.gitignore000066400000000000000000000000121454026223400222520ustar00rootroot00000000000000stdlib_R* paramcoq-1.1.3-coq8.19/test-suite/stdlib_R/Makefile000066400000000000000000000005721454026223400217350ustar00rootroot00000000000000COQSRC=../../../coq/ COQPLUGIN=../../src TOOL=bash ../../tools/coqdep.sh all: Makefile.gen make -f Makefile.gen Makefile.gen graph.dot: $(TOOL) $(COQSRC) graph.png: graph.dot dot -Tpng graph.dot -o graph.png ide: $(COQSRC)/bin/coqide -I $(COQPLUGIN) *.v clean: Makefile.gen make -f Makefile.gen clean rm -f Makefile.gen rm -f graph.dot graph.png rm -f stdlib_*.v paramcoq-1.1.3-coq8.19/test-suite/stdlib_R/Parametricity.v000066400000000000000000000040421454026223400232750ustar00rootroot00000000000000Declare ML Module "coq-paramcoq.plugin". Ltac destruct_reflexivity := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct x; reflexivity; fail end. Ltac destruct_construct x := (destruct x; [ constructor 1 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 ]; auto; fail) || (destruct x; [ constructor 1 | constructor 2 | constructor 3]; auto; fail). Ltac unfold_cofix := intros; match goal with [ |- _ = ?folded ] => let x := fresh "x" in let typ := type of folded in (match folded with _ _ => pattern folded | _ => pattern folded at 2 end); match goal with [ |- ?P ?x ] => refine (let rebuild : typ -> typ := _ in let path : rebuild folded = folded := _ in eq_rect _ P _ folded path) end; [ intro x ; destruct_construct x; fail | destruct folded; reflexivity | reflexivity]; fail end. Ltac destruct_with_nat_arg_pattern x := pattern x; match type of x with | ?I 0 => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun p => _ p | S n => fun _ => unit end q) := _ in gen 0 x) | ?I (S ?n) => refine (let gen : forall m (q : I m), (match m return I m -> Type with 0 => fun _ => unit | S n => fun p => _ p end q) := _ in gen (S n) x) end; intros m q; destruct q. Ltac destruct_reflexivity_with_nat_arg_pattern := intros ; repeat match goal with | [ x : _ |- _ = _ ] => destruct_with_nat_arg_pattern x; reflexivity; fail end. Axiom absurd : forall X, X. Ltac admit_and_print := intros; match goal with | [ |- _ = ?RHS ] => idtac "Warning: admiting an ogligation for" RHS | [ |- ?GOAL] => idtac "Warning: admiting an ogligation of goal" GOAL end; apply absurd. Global Parametricity Tactic := ((destruct_reflexivity; fail) || (unfold_cofix; fail) || (destruct_reflexivity_with_nat_arg_pattern; fail) || admit_and_print). Require ProofIrrelevance. (* for opaque terms *) paramcoq-1.1.3-coq8.19/test-suite/stdlib_R/Readme.md000066400000000000000000000002541454026223400220110ustar00rootroot00000000000000# Not documented yet This makefile generates files that translate all the modules in the standard library. It takes a lot of time. Oh, and also, it's still a bit buggy. paramcoq-1.1.3-coq8.19/test-suite/wadler.v000066400000000000000000000113401454026223400201730ustar00rootroot00000000000000 Require Import List. Require Import Parametricity. Lemma nat_R_equal : forall x y, nat_R x y -> x = y. intros x y H; induction H; subst; trivial. Defined. Lemma equal_nat_R : forall x y, x = y -> nat_R x y. intros x y H; subst. induction y; constructor; trivial. Defined. Definition full_relation {A B} (x : A) (y : B) := True. Definition same_length {A B} := list_R A B full_relation. Lemma same_length_length : forall A B (l1 : list A) (l2 : list B), same_length l1 l2 -> length l1 = length l2. intros A B l1 l2 H. induction H; simpl. reflexivity. exact (f_equal S IHlist_R). Qed. Lemma length_same_length : forall A B (l1 : list A) (l2 : list B), length l1 = length l2 -> same_length l1 l2. admit. (* exercise :) *) Admitted. Module LengthType. Definition T := forall X, list X -> nat. Parametricity T. Definition FREE_THEOREM (f : T) := forall A l1 l2, same_length l1 l2 -> f A l1 = f A l2. Lemma param_length_type : forall f (f_R : T_R f f), FREE_THEOREM f. repeat intro. apply nat_R_equal. apply (f_R A A (fun _ _ => True)). assumption. Qed. Parametricity length. Definition length_rev : T := fun A l => length (rev l). Parametricity Recursive length_rev. Definition double_length : T := fun A l => length (l ++ l). Parametricity Recursive double_length. Definition constant : T := fun A l => 42. Parametricity constant. Definition length_free_theorem : FREE_THEOREM length := param_length_type length length_R. Definition double_length_free_theorem : FREE_THEOREM double_length := param_length_type double_length double_length_R. Definition constant_free_theorem : FREE_THEOREM constant := param_length_type constant constant_R. End LengthType. Definition graph {A B} (f : A -> B) := fun x y => f x = y. Definition map_rel {A B} (f : A -> B) := list_R A B (graph f). Lemma map_rel_map A B (f : A -> B) : forall (l : list A), map_rel f l (map f l). induction l; constructor; compute; auto. Defined. Lemma rel_map_map A B (f : A -> B) : forall (l: list A) fl, map_rel f l fl -> fl = map f l. intros; induction X; unfold graph in *; subst; reflexivity. Defined. Module RevType. Definition T := forall X, list X -> list X. Parametricity T. Definition FREE_THEOREM (F : T) := forall A B (f : A -> B) l, F B (map f l) = map f (F A l). Lemma param_naturality : forall F (F_R : T_R F F), FREE_THEOREM F. repeat intro. apply rel_map_map. apply F_R. apply map_rel_map. Defined. Parametricity rev. Definition tail : T := fun A l => match l with | nil => nil | hd :: tl => tl end. Parametricity tail. Definition rev_rev : T := fun A l => rev (rev l). Parametricity rev_rev. Definition rev_naturality : FREE_THEOREM rev := param_naturality rev rev_R. Definition rev_rev_naturality : FREE_THEOREM rev_rev := param_naturality rev_rev rev_rev_R. Definition tail_naturality : FREE_THEOREM tail := param_naturality tail tail_R. End RevType. Parametricity prod. Definition prod_map {A B} (f : A -> B) {A' B'} (f' : A' -> B') := prod_R A B (graph f) A' B' (graph f'). Definition pair {A B} (f : A -> B) {A' B'} (f' : A' -> B') : A * A' -> B * B' := fun c => let (x, x') := c in (f x, f' x'). Lemma pair_prod_map : forall A B (f : A -> B) A' B' (f' : A' -> B') xy xy', graph (pair f f') xy xy' -> prod_map f f' xy xy'. intros ? ? f ? ? f' [x y] [x' y']. intro H. compute in H. injection H. intros; subst. constructor; reflexivity. Defined. Lemma prod_map_pair : forall A B (f : A -> B) A' B' (f' : A' -> B') xy xy', prod_map f f' xy xy' -> graph (pair f f') xy xy'. intros ? ? f ? ? f' [x y] [x' y']. intro H. compute in H. induction H; subst. reflexivity. Defined. Lemma list_R_prod_map A B (f : A -> B) A' B' (f' : A' -> B') l1 l2 : list_R _ _ (prod_map f f') l1 l2 -> list_R _ _ (graph (pair f f')) l1 l2. intro H; induction H; constructor; [ apply prod_map_pair|]; auto. Defined. Module ZipType. Definition T := forall X Y, list X -> list Y -> list (X * Y). Parametricity T. Definition FREE_THEOREM (F : T) := forall A B (f : A -> B) A' B' (f' : A' -> B') l l', F B B' (map f l) (map f' l') = map (pair f f') (F A A' l l'). Lemma param_ZIP_naturality : forall F (F_R : T_R F F), FREE_THEOREM F. repeat intro. specialize (F_R A B (graph f) A' B' (graph f') l (map f l) (map_rel_map _ _ _ _) l' (map f' l') (map_rel_map _ _ _ _)). apply rel_map_map. unfold map_rel. apply list_R_prod_map. unfold prod_map. assumption. Defined. Fixpoint zip {X Y} (l1 : list X) (l2 : list Y) : list (X * Y) := match l1, l2 with | nil, _ => nil | _, nil => nil | x::tl1, y::tl2 => (x,y)::(zip tl1 tl2) end. Parametricity zip. Definition zip_free_theorem : FREE_THEOREM (@zip) := param_ZIP_naturality _ zip_R. End ZipType. paramcoq-1.1.3-coq8.19/theories/000077500000000000000000000000001454026223400162435ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/theories/Param.v000066400000000000000000000000621454026223400174700ustar00rootroot00000000000000Declare ML Module "paramcoq:coq-paramcoq.plugin". paramcoq-1.1.3-coq8.19/theories/dune000066400000000000000000000002561454026223400171240ustar00rootroot00000000000000(coq.theory (name Param) (package coq-paramcoq) (synopsis "Plugin for generating parametricity statements to perform refinement proofs") (libraries coq-paramcoq.plugin)) paramcoq-1.1.3-coq8.19/tools/000077500000000000000000000000001454026223400155615ustar00rootroot00000000000000paramcoq-1.1.3-coq8.19/tools/coqdep.sh000066400000000000000000000031771454026223400174000ustar00rootroot00000000000000#!/bin/bash COQSRC=../../coq if [ $# -gt 0 ]; then COQSRC=$1 fi PLUGINSRC=../../src if [ $# -gt 1 ]; then PLUGINSRC=$2 fi THEORIES=$COQSRC GENDEP=$( dirname "${BASH_SOURCE[0]}")/gendep.py echo "COQSRC = $COQSRC" echo "PLUGINSRC = $PLUGINSRC" echo "GENDEP = $GENDEP" ARGS=$(find $THEORIES -name "Rdef*.v" | sed 's/^.*coq\///') ARGS="$ARGS $(find $THEORIES -name "Classical_Prop.v" | sed 's/^.*coq\///')" modules=$(find $THEORIES -name '*.d' -exec cat '{}' ';' | grep '\.vo[^:]*: ' | python $GENDEP $ARGS) tmp="/tmp/stdlib.tmp.v" prefix="stdlib_R" makefile="Makefile.gen" for x in $modules; do if [[ $x == *-* ]]; then echo "Parametricity Module $(echo $x | sed 's/-.*$//') as $(echo $x | sed 's/^.*-//')." >> $tmp else echo "Parametricity Module $x." >> $tmp fi done test -f $tmp || exit split -l 15 -d $tmp $prefix --additional-suffix=.v rm -f $tmp cat > $makefile << EOF COQBIN := $COQSRC/bin/ PLUGINSRC := $PLUGINSRC OPTIONS := -I \$(PLUGINSRC) .PHONY: coq clean SRCS=\$(wildcard *.v) OBJS=\$(SRCS:.v=.vo) all: \$(OBJS) %.vo: %.v \$(COQBIN)coqc \$(OPTIONS) \$< Parametricity.vo: Parametricity.v clean: rm -f *.vo *.glob EOF first="$(printf "$prefix%02d" 0)" sed -i "1iRequire Parametricity.\nRequire Import $(echo $modules | sed 's/-[a-Z]*[0-9]*_R//g').\n(* Ignoring the following modules : $ARGS. *)" $first.v echo "$first.vo : $first.v Parametricity.vo" >> $makefile for x in $(seq 0 100); do y=$(($x + 1)) prev="$(printf "$prefix%02d" $x)" file="$(printf "$prefix%02d" $y)" if [ -f "$file.v" ]; then sed -i "1iRequire $prev." $file.v echo "$file.vo : $file.v $prev.vo" >> $makefile fi done paramcoq-1.1.3-coq8.19/tools/gendep.py000066400000000000000000000067331454026223400174060ustar00rootroot00000000000000import sys import os import re from collections import Counter, defaultdict def module_name(x): if 'theories/' in x: y = re.sub(r'^.*theories/','', x) y = re.sub(r'/','.', y) return y else: return os.path.basename(x) def draw (graph, sort, fd): fd.write('digraph {') for x in graph: for y in graph[x]: fd.write('"{0}" -> "{1}";\n'.format(x,y)) if sort: prev = sort[0] for x in sort[1:]: fd.write('"{0}" -> "{1}" [constraint=false color=red];'.format(prev,x)) prev = x fd.write('}') def transitive_reduction(graph, start): aux = defaultdict(Counter) result = defaultdict(list) waiting = list(start) visited = list() while waiting: x = waiting[-1] if not (x in visited): sons = graph[x] all_son_visited = True for son in sons: if not (son in visited): all_son_visited = False if all_son_visited: aux[x].update(sons) for son in sons: if son <> x: aux[x].update(aux[son]) aux[x].update(aux[son]) waiting.pop() visited.append(x) else : waiting.extend(graph[x]) else : waiting.pop() for x in aux: deps = list(k for k in aux[x] if aux[x][k] == 1) result[x] = deps return result def topological_sort(graph, start): def aux (fullfilled, position): if not position in fullfilled: for son in graph[position]: aux(fullfilled, son) fullfilled.append(position) result = list() for x in start: aux (result, x) return result def reverse(graph): result = defaultdict(set) for x in graph: for son in graph[x]: result[son].add(x) return result def remove(graph, starts): rev_graph = reverse(graph) removed = list() while starts : current = starts.pop() if current in graph: for son in rev_graph[current]: starts.append(son) del graph[current] removed.append(current) output = './graph.dot' fd = open(output, 'w') graph = defaultdict(list) for line in sys.stdin.readlines(): line_splitted = line.split(':') targets, needs = line_splitted[0].split(), line_splitted[1].split() targets = list (os.path.splitext(x)[0] for x in targets if x.endswith('.vo')) needs = list (os.path.splitext(x)[0] for x in needs if x.endswith('.vo') or x.endswith('.v')) for x in targets: graph[x].extend(y for y in needs if x <> y) if len(sys.argv) >= 2: removed_nodes = list(os.path.splitext(x)[0] for x in sys.argv[1:]) remove(graph, removed_nodes) init = list(x for x in list(graph) if 'Init/' in x) for x in list(graph) : if not (x in init) : graph[x].extend(init) start = list(graph) reduction = transitive_reduction(graph, start) sort = topological_sort(graph, start) draw(reduction, sort, fd) sort = map(module_name, sort) def aliasing(l): done = defaultdict(int) result = [] for x in l: basename = re.sub(r'^.*\.','', x) done[basename]+=1 if done[basename] > 1: result.append('{0}-{1}{2}_R'.format(x, basename, done[basename])) else: result.append(x) return result sort = aliasing(sort) print(' '.join(sort))