pax_global_header00006660000000000000000000000064147157122520014520gustar00rootroot0000000000000052 comment=af9fab74391a48a7f8fddb28ef280d5110bbb2fb coqhammer-1.3.2-8.20/000077500000000000000000000000001471571225200140645ustar00rootroot00000000000000coqhammer-1.3.2-8.20/CHANGES.md000066400000000000000000000105761471571225200154670ustar00rootroot00000000000000CoqHammer v. 1.3.2 ================== Coq versions compatibility: 8.10, 8.11, 8.12, 8.13, 8.14. Overview of changes ------------------- * Module filtering with the `Hammer Filter` table. * Fixed issue #106 (`sauto` argument parsing bug). * Fixed issue #108. CoqHammer v. 1.3.1 ================== Coq versions compatibility: 8.10, 8.11, 8.12, 8.13. Overview of changes ------------------- * New `sauto` option shorthands: `b:`, `lb:`, `qb:`, `lqb:`, etc. * The `best` tactic which tries several variants of `sauto` in parallel. * Several variants of `sauto` tried in parallel as the preliminary tactic in `hammer`. * Automatic ATP detection in `hammer`. * Proper handling of implicit arguments with `use:`. * Fixed issue #45. CoqHammer v. 1.3 ================ Coq versions compatibility: 8.10, 8.11, 8.12. Overview of changes ------------------- * Proper argument parsing for the automated reasoning tactics. Change of tactic interface. * Optional boolean reflection in `sauto`. * Hint databases can now be used with `sauto`. * Dependent elimination with `depelim` can now be optionally performed by `sauto` (the `dep:` option). * Simplifications for sigma-types in `sauto`. * Improvements of the `sauto` proof search procedure. * Better failure messages for the tactics. * More readable dependency names (without extra qualifiers). * `sauto` is now the preliminary tactic for `hammer`. * Rudimentary MathComp support. New `make` targets: `mathcomp` and `install-mathcomp`. * Tutorial. Details of the sauto proof search improvements ---------------------------------------------- * Actions modulo head reduction. * Better `sdestruct` behaviour with boolean comparisons. * The `f_equal` action. * A major speedup by removing superfluous rewrite hints. * Speedup by using proper Coq API functions for term comparisons. CoqHammer v. 1.2.1 ================== Coq versions compatibility: 8.10, 8.11. Overview of changes ------------------- * Fixed the "Anomaly" error upon `hammer` failure. CoqHammer v. 1.2 ================ Coq versions compatibility: 8.10, 8.11. Overview of changes ------------------- * New reconstruction backend. The reconstruction tactics are now based on a reasonably general proof search procedure for the Calculus of Inductive Constructions and are more useful independently. * Bugfixes in the `predict` program: now compiles with recent versions of GCC and works correctly on macOS. CoqHammer v. 1.1.1 ================== Coq versions compatibility: 8.9, 8.10. Overview of changes ------------------- * Separate packaging of the plugin and the reconstruction tactics. * Quick plugin and tactics tests which do not require ATP provers installed (`make quicktest`, `make test-plugin`, `make test-tactics`). * Machine-learning features now take into account the polarity (positive/negative) of symbol occurrences (`opt_feature_polarity`). * Opaqueness information now taken into account with constant unfolding. CoqHammer v. 1.1 ================ Coq versions compatibility: 8.8, 8.9. Overview of changes ------------------- * CVC4 integration. * Minimization of dependencies. * Parallel invocation of proof tactics. * More reliable timeout mechanism based on `fork` and `wait`. * Improvements in the reconstruction tactics, more rewrite hints for `sauto`. * Change in reconstruction tactics interface. Tactics no longer need a list of hypotheses, and a different set of tactics is used. * Improvements in the translation. * Messages now more user-friendly. * `predict` tactic. * Added `opam` support. * More consistent removal of temporary files. * Debugging commands. * Tests (`make tests`). Technical details of improvements to the translation ---------------------------------------------------- * Hashing of lifted-out terms. * Type lifting (`opt_type_lifting`): hashing of types and lifting them out, e.g., ```coq forall f : nat -> nat, g : (nat -> nat) -> nat -> nat, ... ``` is translated to ```coq forall f, T1(f) -> forall g, T2(g) -> ... ``` with axioms ```coq forall f, T1(f) <-> forall x, nat(x) -> nat(f x) forall g, T2(g) <-> forall h, T1(h) -> forall x, nat(x) -> nat(g h x) ``` instead of translating this to ```coq forall f, (forall x, nat(x) -> nat(f x)) -> forall g, (forall h, (forall x, nat(x) -> nat(h x))) -> forall x, nat(x) -> nat(g h x)) -> ... ``` * `Set` now collapsed to `Type` CoqHammer v. 1.0 ================ Coq versions compatibility: 8.6. First full CoqHammer version. coqhammer-1.3.2-8.20/CONTRIBUTING.md000066400000000000000000000040251471571225200163160ustar00rootroot00000000000000This file contains a few simple general rules for keeping code clean, which are not difficult to apply and save a lot of effort later. Please, read all points and try to follow. 1. Do *not* use TABs, under any circumstances. Set your editor to automatically convert them to spaces. 2. Make sensible indentation. Do *not* use TABs. 3. Within reason, try to follow the coding style of the code already present in the repository, i.e., the same kind of indentation (number of spaces), the same way of inserting newlines, etc. 4. As a general rule, avoid copy & paste. Instead, abstract out a more general parameterised function. 5. Try to make commits which include only things directly relevant to what you're changing. Do not make changes which do nothing (which don't change the behaviour of the code), unless your commit is explicitly about refactoring (cleaning up) code. Avoid including outcommented code, changes of parameters you just used for debugging, hardcoded paths, etc. **Hint**: use `git diff` to review your changes before committing. 6. Try to split commits that do many unrelated things into several commits, each doing one thing. Splitting commits might not always be worth the effort, but it's always worth trying to do this and to keep it in mind. Then the diffs are easy to read, and you can easily find what was changed when and for what purpose. 7. Remove unused code, don't comment it out. With git you can always go back, and really removing things shows up on diffs. 8. When starting on a new thing make a branch (`git branch`, `git checkout -b`) from the most recent development version for a stable version of Coq. This will be in one of the coq8.X branches (ask if not sure). This is *never* the master branch. Branching out from master is bad because the master branch is synchronised with the most recent unstable development version of Coq, which constantly changes and you're then suddenly no longer able to compile things you wrote a few days/weeks/months ago. coqhammer-1.3.2-8.20/CREDITS.md000066400000000000000000000015471471571225200155120ustar00rootroot00000000000000Main authors ------------ * Lukasz Czajka * Logic-related components: translation, proof reconstruction, automated reasoning tactics. Author of almost all OCaml/Ltac/Coq code. Author of the `sauto` tactic. * Cezary Kaliszyk * Machine-learning component: premise selection. Author of the `predict` program. Other contributors ------------------ * Burak Ekici * Preliminary version of boolean reflection in `sauto`. * CVC4 integration. * Evan Marzion * First version of hashing of lifted-out terms in the translation. * Thibault Gauthier * Preliminary version of Coq data export. * Ping Hou * Testing of the `sauto` tactic. * Karl Palmskog * Opam packaging, Travis CI configuration and Dune build scripts. * Other contributors listed on GitHub * Small bugfixes and keeping up-to-date with Coq master. coqhammer-1.3.2-8.20/LICENSE000066400000000000000000000576471471571225200151140ustar00rootroot00000000000000COPYRIGHT Copyright (c) 2017, Łukasz Czajka and Cezary Kaliszyk, University of Innsbruck LICENSE GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS coqhammer-1.3.2-8.20/Makefile000066400000000000000000000056161471571225200155340ustar00rootroot00000000000000 BINDIR ?= $(if $(COQBIN),$(COQBIN),`coqc -where | xargs dirname | xargs dirname`/bin/) default: all all: $(MAKE) tactics $(MAKE) install-tactics $(MAKE) plugin tactics: Makefile.coq.tactics $(MAKE) -f Makefile.coq.tactics plugin: Makefile.coq.plugin Makefile.coq.plugin.local -rm -f META $(MAKE) -f Makefile.coq.plugin mathcomp: Makefile.coq.mathcomp $(MAKE) -f Makefile.coq.mathcomp install: install-tactics install-plugin install-tactics: tactics $(MAKE) -f Makefile.coq.tactics install install-plugin: plugin $(MAKE) -f Makefile.coq.plugin install install-mathcomp: Makefile.coq.mathcomp $(MAKE) -f Makefile.coq.mathcomp install uninstall: uninstall-tactics uninstall-plugin uninstall-tactics: Makefile.coq.tactics $(MAKE) -f Makefile.coq.tactics uninstall uninstall-plugin: Makefile.coq.plugin Makefile.coq.plugin.local $(MAKE) -f Makefile.coq.plugin uninstall uninstall-mathcomp: Makefile.coq.mathcomp $(MAKE) -f Makefile.coq.mathcomp uninstall Makefile.coq.plugin: _CoqProject.plugin coq_makefile -f _CoqProject.plugin -o Makefile.coq.plugin Makefile.coq.tactics: _CoqProject.tactics coq_makefile -f _CoqProject.tactics -o Makefile.coq.tactics Makefile.coq.mathcomp: _CoqProject.mathcomp coq_makefile -f _CoqProject.mathcomp -o Makefile.coq.mathcomp tests: tests-plugin tests-tactics tests-plugin: $(MAKE) -B -C tests/plugin tests-tactics: $(MAKE) -B -C tests/tactics quicktest: test-plugin test-tactics test-plugin: $(MAKE) -B -C tests/plugin plugin_test.vo test-tactics: $(MAKE) -B -C tests/tactics tactics_test.vo clean: Makefile.coq.tactics Makefile.coq.plugin Makefile.coq.plugin.local Makefile.coq.mathcomp $(MAKE) -f Makefile.coq.tactics cleanall -$(MAKE) -f Makefile.coq.plugin cleanall -$(MAKE) -f Makefile.coq.mathcomp cleanall -rm -rf _build rm -f Makefile.coq.tactics Makefile.coq.tactics.conf Makefile.coq.plugin Makefile.coq.plugin.conf Makefile.coq.mathcomp Makefile.coq.mathcomp.conf META dune: dune-tactics dune-plugin dune-tactics: dune build -p coq-hammer-tactics dune-plugin: dune build -p coq-hammer-tactics,coq-hammer dune-install: dune-install-tactics dune-install-plugin dune-install-tactics: dune-tactics dune install coq-hammer-tactics dune-install-plugin: dune-plugin dune install coq-hammer dune-uninstall: dune uninstall coq-hammer coq-hammer-tactics dune-uninstall-tactics: dune uninstall coq-hammer-tactics dune-uninstall-plugin: dune uninstall coq-hammer dune-clean: dune clean $(MAKE) -C eval clean $(MAKE) -C tests/plugin clean $(MAKE) -C tests/tactics clean .PHONY: default all tactics plugin mathcomp install install-tactics install-plugin install-mathcomp uninstall uninstall-tactics uninstall-plugin tests tests-plugin tests-tactics quicktest test-plugin test-tactics clean dune dune-tactics dune-plugin dune-install dune-install-tactics dune-install-plugin dune-clean install-extra dune-uninstall dune-uninstall-tactics dune-uninstall-plugin coqhammer-1.3.2-8.20/Makefile.coq.plugin.local000066400000000000000000000014701471571225200206750ustar00rootroot00000000000000COQ_SRC_SUBDIRS+=user-contrib/Hammer/Tactics CAMLPKGS+= -package coq-hammer-tactics.lib post-all:: predict htimeout predict: src/predict/main.cpp src/predict/predictor.cpp src/predict/format.cpp src/predict/knn.cpp src/predict/nbayes.cpp src/predict/rforest.cpp src/predict/tfidf.cpp src/predict/dtree.cpp c++ -std=c++11 -DCOQ_MODE -O2 -Wall src/predict/main.cpp -o predict htimeout: src/htimeout/htimeout.c cc -O2 -Wall src/htimeout/htimeout.c -o htimeout BINDIR ?= $(if $(COQBIN),$(COQBIN),`coqc -where | xargs dirname | xargs dirname`/bin/) install-extra:: install -d $(DESTDIR)$(BINDIR) install -m 0755 predict $(DESTDIR)$(BINDIR)predict install -m 0755 htimeout $(DESTDIR)$(BINDIR)htimeout clean:: rm -f predict htimeout $(MAKE) -C eval clean $(MAKE) -C tests/plugin clean $(MAKE) -C tests/tactics clean coqhammer-1.3.2-8.20/README.md000066400000000000000000000033021471571225200153410ustar00rootroot00000000000000CoqHammer 1.3.2 for Coq 8.20 (use other branches for other versions of Coq) [![Docker CI][docker-action-shield]][docker-action-link] [docker-action-shield]: https://github.com/lukaszcz/coqhammer/workflows/Docker%20CI/badge.svg?branch=v1.3.2-coq8.20 [docker-action-link]: https://github.com/lukaszcz/coqhammer/actions?query=workflow:"Docker%20CI" CoqHammer video tutorial: [part 1 (sauto)](https://www.youtube.com/watch?v=0c_utk9bVgU&list=PLXXF_svQE_b-9A5p2OKU7Tjz-NcE7H2xg), [part 2 (hammer)](https://www.youtube.com/watch?v=EEmpVCSqShA&list=PLXXF_svQE_b_vja6TWFbGNB266Et8m5yC). Since version 1.3, the CoqHammer system consists of two major separate components. 1. The `sauto` general proof search tactic for the Calculus of Inductive Construction. 2. The `hammer` automated reasoning tool which combines learning from previous proofs with the translation of problems to the logics of external automated systems and the reconstruction of successfully found proofs with the `sauto` procedure. See the [CoqHammer webpage](https://coqhammer.github.io) for documentation and installation instructions. Requirements ------------ - [Coq 8.20](https://github.com/coq/coq) - for `hammer`: automated provers ([Vampire](https://vprover.github.io/download.html), [CVC4](http://cvc4.cs.stanford.edu/downloads/), [Eprover](http://www.eprover.org), and/or [Z3](https://github.com/Z3Prover/z3/releases)) Copyright and license --------------------- Copyright (c) 2017-2024, Lukasz Czajka, TU Dortmund University.\ Copyright (c) 2017-2018, Cezary Kaliszyk, University of Innsbruck. Distributed under the terms of LGPL 2.1, see the file [LICENSE](LICENSE). See [CREDITS](CREDITS.md) for a full list of contributors. coqhammer-1.3.2-8.20/TODO.md000066400000000000000000000144311471571225200151560ustar00rootroot00000000000000Problems -------- 1. Make boolean reflection work. Make CoqHammer usable with MathComp: this will probably require much more than just making boolean reflection work, probably including most of the points below. 2. Omit (some) type arguments (inductive type parameters? implicit type arguments?) to polymorphic functions/constructors (e.g. cons). Is it possible to determine which arguments are implicit at the Coq kernel level? Yes: `Impargs.implicits_of_global`. The easy thing to do first is to just omit the arguments declared as implicit. Then try inductive type parameters? Think about other possibilities. 3. Omit (some) type guards when the type may be inferred. For example, * forall x : nat, Even(x) -> phi probably may be translated to * forall x, Even(x) -> phi', because Even(x) implies nat(x). A non-trivial problem is to precisely formulate a general criterion, and prove it correct for a reasonable subset of CIC. 4. (partly done) For reconstruction: look at the inversion (also discrimination, injection -- less useful?) axioms used in the ATP proofs and add them to the context before invoking a reconstruction tactic. Or use the inversion axioms to specify the "inverting" option of the reconstruction tactics. Make some intelligent use of other information contained in the atp_info data structure (src/plugin/provers.mli). Also look at the axioms for matches, which may sometimes be used by the ATPs to do inversion (see point 7). Try to use even more information from ATP runs. Dig deeper into ATP proofs. 5. Heuristic monomorphisation (instantiation of polymorphic definitions with types). It is important to do this on the translation level and not leave it to the ATPs, because then the translation output may be further optimised. For example, * forall (A : Type) (x : A), phi is translated to * forall A, T(A, Type) -> forall x, T(x, A) -> phi', but in an instantiated version the type guards may be optimised, e.g. for instantiation with nat to: * forall x, nat(x) -> phi'. The monomorphisation is especially important for higher-order statements, whose translations are now not very usable by the ATPs. See e.g. the inversion axiom for List.Forall (Hammer_transl "List.Forall"). 6. Optimise type guards for parameterised types. For instance, forall x : list nat, phi is translated to * forall x, T(x, list nat) -> phi', but should be to * forall x, list_nat(x) -> phi'. This will work well in combination with heuristic monomorphisation. The above example of list with nat parameter is simple, but types in Coq can be complicated. Can we do something when some of the type parameters contain occurrences of variables bound externally? For example: * forall x y, T(x, A) -> T(y, list (Q x)) -> phi. We can, e.g., have an optimised type guard list(Q x, y) or list\_Q(x,y). What are other possibilities? What if T(y, list (Q nat)), maybe then list\_Q\_nat(y)? This problem probably involves much experimentation trying to figure out the right way of doing this. 7. Try breaking up the axiom for matches into one axiom for each constructor. E.g. instead of translating * match x with 0 => t1 | S y => t2 end to: * forall x, nat(x) -> (x = 0 /\ F x = t1') \\/ (exists y, nat(y) /\ x = S y /\ F x = t2') use two axioms: 1. F 0 = t1'[0/x] 2. forall y, nat(y) -> F (S(y)) = t2'[S(y)/x] Note that in point 2 the guard nat(y) should be omitted if `opt_closure_guards` is true (this is analogous to omitting type guards for free variables of lambda-lifted expressions). This is related to program extraction. See Pierre Letouzey’s Ph.D. thesis. 8. Try giving symbol ordering hints to ATPs. There is a natural order on constants: c1 > c2 if transitive-closure(c2 occurs in the definition of c1). This ordering, lifted to lexicographic path order, seems to work well in the reconstruction tactics. See src/lib/lpo.ml and the implementation of rewriting actions in src/tactics/sauto.ml. Extend this idea, try different orderings. 9. Properly handle functions which use dependent types in a non-trivial way. Properly handle case analysis for small propositional inductive types. Properly handle sig, sigT, etc., and prod, sum, etc. with propositional arguments. For example, given ```coq Definition h (x y z : nat) (p : x = y /\ y = z) : {u : nat | x = u} := match p with | conj p1 p2 => exist (fun u => x = u) z (eq_trans p1 p2) end. ``` the function `h` has type ```coq forall x y z : nat, x = y /\ y = z -> {u : nat | x = u} ``` It should be translated to a definition of a function `h` * forall x y z, h(x, y, z) = z and a specification axiom derived from the type * forall x y z, x = y /\ y = z -> x = h(x, y, z) Currently, no function definition for h is generated. Neither is the specification axiom. Only an unusable typing axiom for h is generated. A similar problem is considered in Pierre Letouzey’s Ph.D. thesis, but there the goal is only code extraction, so there is no need to generate the specification axioms derived from types. In addition to program extraction, we need to do *specification extraction*. 10. Explicitly state the types of non-trivial terms. E.g. if f:nat->nat and 0:nat and (f 0) occurs (in the goal or hypothesis?) then state (f 0):nat as an axiom. More general: consider non-trivial terms as possible premises. This ties in with monomorphisation. What types to choose for instantiating e.g. list? Do machine-learning premise selection with (list nat), (list Z), etc. among premises. 11. Improvements in premise selection: better features, other algorithms? Special status for head constants? 12. Translation to HOL. Factor the translation, including a HOL intermediate stage: Coq -> CIC_0 -> HOL -> applicative FOL -> FOL. Try using higher-order ATPs. 13. Write a custom version of the `eapply` tactic which does unification modulo "simple" (equational?) reasoning. See the smart matching of Matita. 14. Optional use of classical logic. Technical improvements ---------------------- 1. Remove dependence on "grep". 2. Make the plugin work on Windows. coqhammer-1.3.2-8.20/_CoqProject.mathcomp000066400000000000000000000000771471571225200200320ustar00rootroot00000000000000-Q theories/Tactics Hammer.Tactics theories/Tactics/Mathcomp.v coqhammer-1.3.2-8.20/_CoqProject.plugin000066400000000000000000000013551471571225200175200ustar00rootroot00000000000000src/plugin/META.coq-hammer -Q theories/Plugin Hammer.Plugin -Q src/plugin Hammer.Plugin -I src/plugin src/plugin/hh_term.ml src/plugin/msg.ml src/plugin/timeout.ml src/plugin/coq_transl_opts.ml src/plugin/coqterms.ml src/plugin/defhash.mli src/plugin/defhash.ml src/plugin/coq_typing.mli src/plugin/coq_typing.ml src/plugin/hashing.mli src/plugin/hashing.ml src/plugin/coq_convert.mli src/plugin/coq_convert.ml src/plugin/tptp_out.mli src/plugin/tptp_out.ml src/plugin/coq_transl.mli src/plugin/coq_transl.ml src/plugin/opt.ml src/plugin/parallel.ml src/plugin/features.mli src/plugin/features.ml src/plugin/provers.mli src/plugin/provers.ml src/plugin/hammer_main.ml src/plugin/g_hammer.mlg src/plugin/hammer_plugin.mlpack theories/Plugin/Hammer.v coqhammer-1.3.2-8.20/_CoqProject.tactics000066400000000000000000000012471471571225200176540ustar00rootroot00000000000000src/tactics/META.coq-hammer-tactics -Q theories/Tactics Hammer.Tactics -Q src/lib Hammer.Tactics -Q src/tactics Hammer.Tactics -I src/lib -I src/tactics src/lib/hammer_errors.ml src/lib/hhutils.mli src/lib/hhutils.ml src/lib/hhlib.ml src/lib/hhlpo.mli src/lib/hhlpo.ml src/lib/hhpartac.ml src/lib/g_hammer_lib.mlg src/lib/hammer_lib.mlpack src/tactics/sauto.mli src/tactics/sauto.ml src/tactics/tacopts.mli src/tactics/tacopts.ml src/tactics/tacbest.mli src/tactics/tacbest.ml src/tactics/tactics_main.ml src/tactics/g_hammer_tactics.mlg src/tactics/hammer_tactics.mlpack theories/Tactics/Reconstr.v theories/Tactics/Reflect.v theories/Tactics/Tactics.v theories/Tactics/Hints.v coqhammer-1.3.2-8.20/coq-hammer-tactics.opam000066400000000000000000000016541471571225200204310ustar00rootroot00000000000000opam-version: "2.0" version: "1.3.2+8.20" maintainer: "palmskog@gmail.com" homepage: "https://github.com/lukaszcz/coqhammer" dev-repo: "git+https://github.com/lukaszcz/coqhammer.git" bug-reports: "https://github.com/lukaszcz/coqhammer/issues" license: "LGPL-2.1-only" synopsis: "Reconstruction tactics for the hammer for Coq" description: """ Collection of tactics that are used by the hammer for Coq to reconstruct proofs found by automated theorem provers. When the hammer has been successfully applied to a project, only this package needs to be installed; the hammer plugin is not required. """ build: [make "-j%{jobs}%" "tactics"] install: [ [make "install-tactics"] [make "test-tactics"] {with-test} ] depends: [ "ocaml" {>= "4.09.0"} "coq" {>= "8.20" & < "8.21~"} ] tags: [ "keyword:automation" "keyword:hammer" "keyword:tactics" "logpath:Hammer.Tactics" ] authors: [ "Lukasz Czajka " ] coqhammer-1.3.2-8.20/coq-hammer.opam000066400000000000000000000020551471571225200167750ustar00rootroot00000000000000opam-version: "2.0" version: "1.3.2+8.20" maintainer: "palmskog@gmail.com" homepage: "https://github.com/lukaszcz/coqhammer" dev-repo: "git+https://github.com/lukaszcz/coqhammer.git" bug-reports: "https://github.com/lukaszcz/coqhammer/issues" license: "LGPL-2.1-only" synopsis: "General-purpose automated reasoning hammer tool for Coq" description: """ A general-purpose automated reasoning hammer tool for Coq that combines learning from previous proofs with the translation of problems to the logics of automated systems and the reconstruction of successfully found proofs. """ build: [make "-j%{jobs}%" "plugin"] install: [ [make "install-plugin"] [make "test-plugin"] {with-test} ] depends: [ "ocaml" {>= "4.09.0"} "coq" {>= "8.20" & < "8.21~"} ("conf-g++" {build} | "conf-clang" {build}) "coq-hammer-tactics" {= version} ] tags: [ "category:Miscellaneous/Coq Extensions" "keyword:automation" "keyword:hammer" "logpath:Hammer.Plugin" ] authors: [ "Lukasz Czajka " "Cezary Kaliszyk " ] coqhammer-1.3.2-8.20/dune000066400000000000000000000006741471571225200147510ustar00rootroot00000000000000(env (dev (flags (:standard -w -27 -w -3)))) (rule (targets predict) (deps (sandbox always) (source_tree src/predict)) (action (run c++ -std=c++11 -DCOQ_MODE -O2 -Wall src/predict/main.cpp -o predict))) (rule (targets htimeout) (deps (sandbox always) (source_tree src/htimeout)) (action (run cc -O2 -Wall src/htimeout/htimeout.c -o htimeout))) (install (files predict htimeout) (section bin) (package coq-hammer)) coqhammer-1.3.2-8.20/dune-project000066400000000000000000000000411471571225200164010ustar00rootroot00000000000000(lang dune 3.8) (using coq 0.8) coqhammer-1.3.2-8.20/eval/000077500000000000000000000000001471571225200150135ustar00rootroot00000000000000coqhammer-1.3.2-8.20/eval/Makefile000066400000000000000000000024641471571225200164610ustar00rootroot00000000000000# input files FFILES=$(shell find problems/ -name "*.v" | sort -R) OFILES=$(patsubst problems/%.v,problems/%.vo,$(FFILES)) COQC=coqc $(shell find problems/ -name "*.conf" -exec cat {} + | tr "\n" " ") all: @echo "See README on how to invoke make." init: $(OFILES) problems/%.vo: problems/%.v @mkdir -p logs/init $(COQC) "$<" > logs/init/`basename "$@" .vo`.log 2>&1 check: $(patsubst problems/%.v,logs/check/%.log,$(FFILES)) logs/check/%.log: problems/%.v @mkdir -p `dirname "$@"` $(COQC) "$<" > "$@" 2>&1 atp: $(patsubst problems/%.v,logs/atp/%.log,$(FFILES)) logs/atp/%.log: problems/%.v @mkdir -p `dirname "$@"` $(COQC) "$<" > "$@" 2>&1 reconstr: $(patsubst problems/%.v,logs/reconstr/%.log,$(FFILES)) logs/reconstr/%.log: problems/%.v @mkdir -p `dirname "$@"` $(COQC) "$<" > "$@" 2>&1 prove: $(patsubst problems/%.v,logs/prove/%.log,$(FFILES)) logs/prove/%.log: problems/%.v @mkdir -p `dirname "$@"` $(COQC) "$<" > "$@" 2>&1 clean-vo: rm -f $(OFILES) clean: clean-vo rm -rf logs coqhammer.opt check.log gen_atp.log $(MAKE) -C tools clean clean-problems: clean-vo rm -f $(patsubst problems/%.v,problems/.%.aux,$(FFILES)) rm -f $(patsubst problems/%.v,problems/%.v.bak,$(FFILES)) rm -f $(patsubst problems/%.v,problems/%.glob,$(FFILES)) .PHONY: clean clean-vo clean-problems check atp reconstr init all coqhammer-1.3.2-8.20/eval/README.md000066400000000000000000000067101471571225200162760ustar00rootroot00000000000000How to evaluate a new Coq library? ---------------------------------- Let `N` be the number of parallel jobs to execute. Unless otherwise stated, execute all commands in the `eval/` directory. Some libraries prepared for evaluation are available at https://github.com/lukaszcz/coqhammer-eval.git. If the library to evaluate is already prepared (according to steps 1-6 below), then put it in the `problems/` subdirectory and do: ```bash ./run-eval.sh N [your.mail@mail.com] ``` Otherwise follow all steps below. You may find `make clean-problems` useful when you want to redo some steps. 1. Place the library sources in the `problems/` directory (possibly with subdirectories). The sources should contain the `*.v` files. 2. `cd tools && make` 3. Run `tools/fixreqs.sh prefix` in the `problems/` directory to fix the `Require` statements. This script expects one parameter -- the Coq logical prefix for the library. All `Require file` (also `Require Import` and `Require Export`) statements for files which are found in the `problems/` directory are changed to `From prefix Require file`. 4. `make -j N init` This will compile the problems, creating the necessary `*.glob` files. If some files do not compile then you need to fix this manually. 5. `cd problems && ../tools/mkhooks.sh` This script may be used to insert calls to `hammer_hook` in the library source files (it requires the corresponding `*.glob` files to be present). Run it in the `problems/` directory. After running `tools/mkhooks.sh` you may need to edit some files manually to make them compile with `coqc`. 6. `./check.sh N` This checks if the problems compile with `coqc` after running `tools/mkhooks.sh`. It may fail for some files, which must be then edited manually to make them compile with `coqc`. The errors may be viewed in the `check.log` file. 7. `./gen-atp.sh N [your.mail@mail.com]` After running this command the generated ATP problems are in the `atp/problems/` directory. 8. `cd atp && ./run-provers.sh N [your.mail@mail.com]` The script `atp/run-provers.sh` should be edited when adding or changing the (versions of) ATP provers used in the evaluation. When adding new ATPs also the `hammer_hook` code in [`src/plugin/hammer_main.ml`](../src/plugin/hammer_main.ml) should be edited. 9. `./run-reconstr.sh N [your.mail@mail.com]` After executing these steps, the reconstruction results are in the `out/` directory. The ATP results are in the `atp/o/` directory. 10. `./gen-stats.sh` This computes the statistics (including the greedy sequence), using the `stat` program (see below). Steps 7-10 may be run using the script `./run-eval.sh [-v] N [your.mail@mail.com]`. The optional flag -v enables the verbose mode (more emails about the progress are sent). Tools ----- * `stat`: compute ATP statistics. Run in the `atp/` directory (or `eval/` with the `-r` option). Reads the `o/*/*.p` files (`out/*/*.out` with the `-r` option). Example: `tools/stat , y,p , , false` `stat` takes 5 (optionally 6) space-separated arguments: the `-r` option (optional), 4 lists (comma-separated values; empty list is represented by a single comma) and a boolean ``` stat -r [labels] [sorting specification] [which fields to merge] [greedy sequence fixed start] (should different versions of the greedy sequence be computed?) ``` - `y` - the number of proved theorems - `n` - the number of countersatisfiable problems - `p` - the prover coqhammer-1.3.2-8.20/eval/atp/000077500000000000000000000000001471571225200155775ustar00rootroot00000000000000coqhammer-1.3.2-8.20/eval/atp/Makefile000066400000000000000000000016101471571225200172350ustar00rootroot00000000000000# # ATP evaluation # # See README for details. # # input files FFILES=$(shell find i/f/ -type f | sort -R) # timeout (in seconds) TIM=30 all: eprover vampire z3 cvc4 eprover: $(patsubst i/f/%,o/eprover/%,$(FFILES)) o/eprover/%: i/f/% @mkdir -p `dirname "$@"` @eprover -s --cpu-limit=$(TIM) --auto-schedule -R --print-statistics -p --tstp-format "$<" | grep "file[(]'\|# SZS" > "$@" vampire: $(patsubst i/f/%,o/vampire/%,$(FFILES)) o/vampire/%: i/f/% @mkdir -p `dirname "$@"` @htimeout $(TIM) vampire --mode casc -t $(TIM) --proof tptp --output_axiom_names on "$<" | grep "file[(]'\|% SZS" > "$@" z3: $(patsubst i/f/%,o/z3/%,$(FFILES)) o/z3/%: i/f/% @mkdir -p `dirname "$@"` @htimeout $(TIM) z3_tptp -c -t:$(TIM) "-file:$<" > "$@" cvc4: $(patsubst i/f/%,o/cvc4/%,$(FFILES)) o/cvc4/%: i/f/% @mkdir -p `dirname "$@"` @htimeout $(TIM) cvc4 --tlimit $(TIM) --dump-unsat-cores-full "$<" > "$@" coqhammer-1.3.2-8.20/eval/atp/README.md000066400000000000000000000013651471571225200170630ustar00rootroot00000000000000ATP performance evaluation -------------------------- Given a set of ATP problems, the Makefile in this directory runs ATPs to determine which problems ATPs are able to solve within a given time. The input files need to be in subdirectories of `i`: * `i/f` should contain all the FOF files to evaluate. * `i/h` may contain all the THF files to evaluate. * `i/w` may contain all the Why3 files to evaluate. The outputs are written to `o/$prover_name/...` To run, use `make -j 47 -k` (where 47 is the number of CPUs). The parameter `-k` resumes evaluation in case of errors. The timeout can be set in the Makefile. Optionally only particular provers may be specified, e.g. `make eprover`. Warning: Rerun `make` to ensure that all problems were treated. coqhammer-1.3.2-8.20/eval/atp/run-provers.sh000077500000000000000000000006751471571225200204500ustar00rootroot00000000000000#!/bin/bash mkdir i for d in problems/* do echo "***************" echo $d rm -f i/f ln -s ../$d i/f make -k -j "$1" eprover vampire z3 cvc4 p=`basename $d` mv o/eprover o/eprover-$p mv o/vampire o/vampire-$p mv o/z3 o/z3-$p mv o/cvc4 o/cvc4-$p if [ -n "$2" ]; then echo "" | mail -s "provers $p finished" "$2" fi done if [ -n "$2" ]; then echo "" | mail -s "Provers finished" "$2" fi coqhammer-1.3.2-8.20/eval/check.sh000077500000000000000000000003141471571225200164250ustar00rootroot00000000000000#!/bin/bash echo "check" > coqhammer.opt rm -rf logs/check/ rm check.log make -k -j "$1" check 2>&1 | tee check.log mv check.log check.log.bak cat check.log.bak | grep Error > check.log rm check.log.bak coqhammer-1.3.2-8.20/eval/gen-atp.sh000077500000000000000000000005011471571225200167010ustar00rootroot00000000000000#!/bin/bash echo "gen-atp" > coqhammer.opt rm -rf logs/atp/ rm -rf atp/problems rm gen-atp.log make -k -j "$1" atp 2>&1 | tee gen-atp.log mv gen-atp.log gen-atp.log.bak cat gen-atp.log.bak | grep Error > gen-atp.log rm gen-atp.log.bak if [ -n "$2" ]; then echo "" | mail -s "ATP problem generation finished" "$2" fi coqhammer-1.3.2-8.20/eval/gen-stats.sh000077500000000000000000000101031471571225200172520ustar00rootroot00000000000000#!/bin/bash cd tools make cd .. cd atp ../tools/stat , y,p , , false cd .. tools/stat -r , y,p , , false echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "
hautoxeautoscrushqcrush
" >> statistics.html echo `find out -name "*.out" -exec grep 'hauto$' {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep xeauto {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep scrush {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep 'qcrush$' {} + | wc -l` >> statistics.html echo "
" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "
leautoqproversyellessreconstr
" >> statistics.html echo `find out -name "*.out" -exec grep 'leauto' {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep qprover {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep 'syelles' {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep sreconstr {} + | wc -l` >> statistics.html echo "
" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "
qblastsblastqcrush2hcrush
" >> statistics.html echo `find out -name "*.out" -exec grep 'qblast' {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep 'sblast' {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep 'qcrush2' {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep hcrush {} + | wc -l` >> statistics.html echo "
" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "
rryellesrrcrushrryreconstrrrblast
" >> statistics.html echo `find out -name "*.out" -exec grep rryelles {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep rrcrush {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep rryreconstr {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep rrblast {} + | wc -l` >> statistics.html echo "
" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "" >> statistics.html echo "
rfirstorderxeautortautoreasy
" >> statistics.html echo `find out -name "*.out" -exec grep rfirstorder {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep xeauto {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep rtauto {} + | wc -l` >> statistics.html echo "" >> statistics.html echo `find out -name "*.out" -exec grep reasy {} + | wc -l` >> statistics.html echo "
" >> statistics.html coqhammer-1.3.2-8.20/eval/gen-tests.sh000077500000000000000000000002541471571225200172640ustar00rootroot00000000000000#!/bin/bash rm -f problems || rm -rf problems cd tests make clean cd .. cp -r tests problems echo "check" > coqhammer.opt cd tests make -k -j "$1" cd .. ./gen-atp.sh "$1" coqhammer-1.3.2-8.20/eval/run-eval.sh000077500000000000000000000002641471571225200171050ustar00rootroot00000000000000#!/bin/bash ./gen-atp.sh $1 $2 cd atp ./run-provers.sh $1 $2 cd .. ./run-reconstr.sh $1 $2 ./gen-stats.sh if [ -n "$2" ]; then echo "" | mail -s "Evaluation finished" "$2" fi coqhammer-1.3.2-8.20/eval/run-prove.sh000077500000000000000000000004031471571225200173040ustar00rootroot00000000000000#!/bin/bash make clean-vo echo "prove" > coqhammer.opt make -k -j "$1" prove echo -n "Total problems: " ls out/*.out | wc -l echo -n "Successes: " grep "^Success " out/*.out | wc -l if [ -n "$2" ]; then echo "" | mail -s "Coq proving finished" "$2" fi coqhammer-1.3.2-8.20/eval/run-reconstr.sh000077500000000000000000000002651471571225200200160ustar00rootroot00000000000000#!/bin/bash make clean-vo echo "reconstr" > coqhammer.opt make -k -j `echo "($1-4)/4+1" | bc` reconstr if [ -n "$2" ]; then echo "" | mail -s "Reconstruction finished" "$2" fi coqhammer-1.3.2-8.20/eval/tools/000077500000000000000000000000001471571225200161535ustar00rootroot00000000000000coqhammer-1.3.2-8.20/eval/tools/Makefile000066400000000000000000000006521471571225200176160ustar00rootroot00000000000000all: stat coqnames rmcomments fixreqs rm -f *.cm* *.o stat: utils.ml stat.ml ocamlopt -inline 100 -unsafe unix.cmxa str.cmxa $^ -o $@ coqnames: utils.ml coqnames.ml ocamlopt -inline 100 -unsafe unix.cmxa str.cmxa $^ -o $@ fixreqs: utils.ml fixreqs.ml ocamlopt -inline 100 -unsafe unix.cmxa str.cmxa $^ -o $@ rmcomments: rmcomments.c gcc $^ -o $@ clean: -rm -f rmcomments coqnames fixreqs stat *.cmo *.cmi *.cmx *.o coqhammer-1.3.2-8.20/eval/tools/coqnames.ml000066400000000000000000000147451471571225200203260ustar00rootroot00000000000000(* The program to extract "theorems" from Coq source code *) module Lib = Utils let is_idchar = function 'A'..'Z'|'a'..'z'|'0'..'9'|'_'|'\'' -> true | _ -> false let get_name s n = let len = String.length s in let rec pom s n = if n >= len then n else if is_idchar (String.get s n) then pom s (n + 1) else n in if n >= len then "" else let k = pom s n in String.sub s n (k - n) let find_dot s i = let len = String.length s in let rec pom j in_quote = if j >= len then j else if (not in_quote) && String.get s j = '.' then j + 1 else pom (j + 1) (if String.get s j = '\"' then not in_quote else in_quote) in pom i false let remove_hammer_hook s = try let i = Str.search_forward (Str.regexp "hammer_hook ") s 0 in let len = String.length s in let k = find_dot s i in String.sub s 0 i ^ String.sub s k (len - k) with Not_found -> s let process_file fname = let nametab = Hashtbl.create 64 in let create_nametab tfname = let rec pom prefix ic = begin try let s = input_line ic in let i = String.index s ' ' in let p = String.sub s 0 i in let x = String.sub s (i + 1) (String.length s - i - 1) in let v = if p <> "<>" then prefix ^ "." ^ p else prefix in if Hashtbl.mem nametab x then Queue.push v (Hashtbl.find nametab x) else begin let stack = Queue.create () in Queue.push v stack; Hashtbl.add nametab x stack end with Not_found -> () end; pom prefix ic in let ic = open_in tfname in let s = input_line ic in let prefix = String.sub s 1 (String.length s - 1) in try pom prefix ic with End_of_file -> close_in ic; prefix in let rec pom prefix ic oc last = let s = String.trim (input_line ic) in let last2 = if Lib.string_begins_with s "Instance " then get_name s (String.length "Instance ") else if Lib.string_begins_with s "Theorem " then get_name s (String.length "Theorem ") else if Lib.string_begins_with s "Lemma " then get_name s (String.length "Lemma ") else if Lib.string_begins_with s "Definition " then get_name s (String.length "Definition ") else if Lib.string_begins_with s "Fact " then get_name s (String.length "Fact ") else if Lib.string_begins_with s "Corollary " then get_name s (String.length "Corollary ") else if Lib.string_begins_with s "Example " then get_name s (String.length "Example ") else if Lib.string_begins_with s "Remark " then get_name s (String.length "Remark ") else if Lib.string_begins_with s "Global Instance " then get_name s (String.length "Global Instance ") else if Lib.string_begins_with s "Program Instance " then get_name s (String.length "Program Instance ") else if Lib.string_begins_with s "Program Definition " then get_name s (String.length "Program Definition ") else if Lib.string_begins_with s "Program Lemma " then get_name s (String.length "Program Lemma ") else if Lib.string_begins_with s "Program Theorem " then get_name s (String.length "Program Theorem ") else if Lib.string_begins_with s "Program Fact " then get_name s (String.length "Program Fact ") else if Lib.string_begins_with s "Program Corollary " then get_name s (String.length "Program Corollary ") else if Lib.string_begins_with s "Global Program Instance " then get_name s (String.length "Global Program Instance ") else if Lib.string_begins_with s "Local Instance " then get_name s (String.length "Local Instance ") else if Lib.string_begins_with s "Local Program Instance " then get_name s (String.length "Local Program Instance ") else if Lib.string_begins_with s "Let " then get_name s (String.length "Let ") else last in begin let s = remove_hammer_hook s in try if Lib.string_begins_with s "Proof." || Lib.string_begins_with s "Proof with " || Lib.string_begins_with s "Proof using " || Lib.string_begins_with s "Proof using." then begin let pref = Queue.pop (Hashtbl.find nametab last2) in let path = pref ^ "." ^ last2 in let i = String.index s '.' in let p = String.sub s 0 (i + 1) in let r = if i + 1 = String.length s then "" else (String.sub s (i + 1) (String.length s - i - 1)) in output_string oc (p ^ " hammer_hook \"" ^ prefix ^ "\" \"" ^ path ^ "\"." ^ r ^ "\n"); print_endline path end else if Lib.string_begins_with s "Proof " then begin let pref = Queue.pop (Hashtbl.find nametab last2) in let path = pref ^ "." ^ last2 in let p = String.sub s 6 (String.length s - 7) in output_string oc ("Proof. hammer_hook \"" ^ prefix ^ "\" \"" ^ path ^ "\". " ^ "exact (" ^ p ^ "). Qed.\n"); print_endline path end else output_string oc (s ^ "\n") with Not_found | Queue.Empty -> output_string oc (s ^ "\n") end; pom prefix ic oc last2 in let gname = (Filename.chop_suffix fname ".v") ^ ".glob" in let cmd1 = "grep \"^F\" " ^ gname and cmd2 = "grep -v \"^R\" " ^ gname ^ " | tail -n+2 | cut -d ' ' -f 3,4" in let tfname = Filename.temp_file "coqnames" ".glob" and ofname = Filename.temp_file "coqnames" ".v" in ignore (Sys.command (cmd1 ^ " > " ^ tfname)); ignore (Sys.command (cmd2 ^ " >> " ^ tfname)); let prefix = create_nametab tfname in Sys.remove tfname; let ic = open_in fname and oc = open_out ofname in output_string oc "From Hammer Require Import Hammer.\n\n"; try pom prefix ic oc "" with End_of_file -> close_in ic; close_out oc; ignore (Sys.command ("mv " ^ ofname ^ " " ^ fname)) let rec process_dir dir = let entries = Sys.readdir dir in Sys.chdir dir; Array.iter begin fun fname -> if Sys.is_directory fname then process_dir fname else if Filename.check_suffix fname ".v" then process_file fname else () end entries; Sys.chdir ".." ;; process_dir "." coqhammer-1.3.2-8.20/eval/tools/fixreqs.ml000066400000000000000000000032111471571225200201630ustar00rootroot00000000000000(* The program to fix "Require" statements in Coq source code *) let remove_trailing_dot s = let len = String.length s in if len > 0 && String.get s (len - 1) = '.' then String.sub s 0 (len - 1) else s let process_file fname = let rec pom ic oc = let rec hlp prefix lst = match lst with | file :: lst2 -> let from = if Sys.file_exists (file ^ ".v") then "From " ^ Sys.argv.(1) ^ " " else "" in output_string oc (from ^ prefix ^ file ^ ".\n"); hlp prefix lst2 | [] -> () in let s = String.trim (input_line ic) in begin let words = Str.split (Str.regexp "[ ]+") (remove_trailing_dot s) in match words with | "Require" :: "Import" :: lst -> hlp "Require Import " lst | "Require" :: "Export" :: lst -> hlp "Require Export " lst | "Require" :: lst -> hlp "Require " lst | _ -> output_string oc (s ^ "\n") end; pom ic oc in let ofname = Filename.temp_file "fixreqs" ".v" in let ic = open_in fname and oc = open_out ofname in try pom ic oc with End_of_file -> close_in ic; close_out oc; ignore (Sys.command ("mv " ^ ofname ^ " " ^ fname)) let rec process_dir dir = let entries = Sys.readdir dir in Sys.chdir dir; Array.iter begin fun fname -> if Sys.is_directory fname then process_dir fname else if Filename.check_suffix fname ".v" then process_file fname else () end entries; Sys.chdir ".." ;; if Array.length Sys.argv <> 2 then prerr_endline "usage: fixreqs prefix" else process_dir "." coqhammer-1.3.2-8.20/eval/tools/fixreqs.sh000077500000000000000000000001121471571225200201650ustar00rootroot00000000000000#!/bin/bash DIR=`dirname "$0"` "$DIR/rmcomments.sh" "$DIR/fixreqs" "$1" coqhammer-1.3.2-8.20/eval/tools/mkhooks.sh000077500000000000000000000001061471571225200201620ustar00rootroot00000000000000#!/bin/bash DIR=`dirname "$0"` "$DIR/rmcomments.sh" "$DIR/coqnames" coqhammer-1.3.2-8.20/eval/tools/rmcomments.c000066400000000000000000000013401471571225200205010ustar00rootroot00000000000000 #include int main() { int c; int prev = 0; int nesting = 0; int in_string = 0; while ((c = getchar()) != EOF) { if (prev == '(' && c == '*' && !in_string) { ++nesting; } else if (prev == '*' && c == ')' && !in_string && nesting > 0) { --nesting; prev = getchar(); if (prev == EOF) { break; } continue; } if (nesting == 0 && prev != 0) { putchar(prev); } prev = c; if (c == '"' && nesting == 0) { in_string = 1 - in_string; } } if (nesting == 0 && prev != 0 && prev != EOF) { putchar(prev); } return 0; } coqhammer-1.3.2-8.20/eval/tools/rmcomments.sh000077500000000000000000000002201471571225200206700ustar00rootroot00000000000000#!/bin/bash DIR=`dirname "$0"` for f in `find . -name "*.v" -print`; do cp "$f" "$f.bak" cat "$f.bak" | "$DIR/rmcomments" > "$f" done coqhammer-1.3.2-8.20/eval/tools/stat.ml000066400000000000000000000362031471571225200174640ustar00rootroot00000000000000open Utils;; let reconstr_mode = ref false let comma_rxp = Str.regexp ",";; let pom l s nos fg g2 = (Str.split comma_rxp l, Str.split comma_rxp s, List.sort compare (List.map int_of_string (Str.split comma_rxp nos)), Str.split comma_rxp fg, bool_of_string g2);; let (collabels, sortmode, merge_nos, fixgreed, greed2) = match Array.to_list Sys.argv with | [_; "-r"; l; s; nos; fg; g2] -> reconstr_mode := true; pom l s nos fg g2 | [_; l; s; nos; fg; g2] -> pom l s nos fg g2 | _ -> failwith "Usage: stath (labels) (sorting) (merging) (fixgreed) greed2\nwhere [sorting] can be none, sort, greed and [megring] are nos to merge from back";; let proto_rxp = Str.regexp "protokoll";; let dirents d = let dirh = Unix.opendir d in let goodname s = s <> "." && s <> ".." && (try ignore (Str.search_forward proto_rxp s 0); false with Not_found -> true) in let rec fs acc = try fs (let l = Unix.readdir dirh in if goodname l then l :: acc else acc) with End_of_file -> acc in let ret = fs [] in Unix.closedir dirh; ret ;; let rec rdirents prefix acc d = try let dirh = Unix.opendir (prefix ^ d) in let goodname s = s <> "." && s <> ".." && (try ignore (Str.search_forward proto_rxp s 0); false with Not_found -> true) in let rec fs acc = try fs (let l = Unix.readdir dirh in if goodname l then rdirents (prefix ^ d ^ "/") acc l else acc) with End_of_file -> acc in let ret = fs acc in Unix.closedir dirh; ret with Unix.Unix_error (Unix.ENOTDIR, _, _) -> (prefix ^ d) :: acc ;; let rdirents () = if !reconstr_mode then let l = rdirents "" [] "atp/i/f" in List.map (fun s -> String.sub s 8 (String.length s - 8)) l else let l = rdirents "" [] "i/f" in List.map (fun s -> String.sub s 4 (String.length s - 4)) l ;; let dash_rxp = Str.regexp "-";; let unmerged_atps = Array.of_list (dirents (if !reconstr_mode then "out" else "o"));; let rec replace_nos str_lst = function [] -> str_lst | no :: nos -> match str_lst with [] -> failwith "Merge non-existing fields" | sh :: st -> let pnos = List.map pred nos in if no = 0 then "*" :: replace_nos st pnos else sh :: replace_nos st (pred no :: pnos);; let replace_nos s = String.concat "-" (List.rev (replace_nos (List.rev (Str.split dash_rxp s)) merge_nos));; let merged_atps = Hashtbl.create 100;; let merged_atp_no = ref 0;; let replh = Hashtbl.create 100;; let replnoh = Hashtbl.create 100;; Array.iteri (fun un ua -> let ma = replace_nos ua in Hashtbl.replace replh ua ma; try let mn = Hashtbl.find merged_atps ma in Hashtbl.replace replnoh un mn with Not_found -> Hashtbl.add merged_atps ma !merged_atp_no; Hashtbl.replace replnoh un !merged_atp_no; incr merged_atp_no) unmerged_atps;; let reverse_hash h = let nh = Hashtbl.create (Hashtbl.length h) in Hashtbl.iter (fun a b -> Hashtbl.add nh b a) h; nh;; let atpno = !merged_atp_no;; let no_atp = reverse_hash merged_atps;; let atps = Array.init atpno (Hashtbl.find no_atp);; let fixgreed = List.map (fun i -> try Hashtbl.find merged_atps i with _ -> -1) fixgreed;; let fs = Array.of_list (rdirents ());; let fsno = Array.length fs;; Printf.eprintf "e%!";; let reg1 = Str.regexp ".*\\(SZS status Theorem\\|SZS status Unsatisfiable\\| : Valid (\\|SPASS beiseite: Proof found.\\|^Success \\|^THEOREM PROVED$\\)";; let reg2 = Str.regexp ".*\\(SZS status CounterSatisfiable\\|Non-Theorem\\)";; let reg3 = Str.regexp ".*\\(SZS status Timeout\\|SZS status Unknown\\| : Unknown (\\|SZS status ResourceOut\\|^Failure \\|^SPASS beiseite: Ran out of time. SPASS was killed.$\\)";; let reg4 = Str.regexp ".*\\( [eE]rror\\| HighFailure\\|ExitFailure\\|PARSE ERROR\\)";; let evalf fname = try let inc = open_in fname in let rec ans () = try let l = input_line inc in if Str.string_match reg1 l 0 then 5 else if Str.string_match reg2 l 0 then 4 else if Str.string_match reg3 l 0 then 3 else if Str.string_match reg4 l 0 then 2 else ans () with End_of_file -> close_in inc; 1 in let ret = ans () in close_in inc; ret with _ -> 0 ;; let ans = Array.init atpno (fun atp -> Array.create fsno 0);; for uatpno = 0 to Array.length unmerged_atps - 1 do let uatpn = unmerged_atps.(uatpno) in let matpno = Hashtbl.find replnoh uatpno in let fv = ans.(matpno) in for f = 0 to fsno - 1 do let oret = fv.(f) in if oret = 5 then () else begin let name = (if !reconstr_mode then "out/" else "o/") ^ uatpn ^ "/" ^ fs.(f) in let name = if !reconstr_mode then Filename.chop_extension name ^ ".out" else name in let nret = evalf name in if nret > oret then fv.(f) <- nret end done done;; Printf.eprintf "a%!";; (* Problems per atp *) let pps = Array.init atpno (fun matpno -> Array.fold_left (fun s x -> if x > 0 then s + 1 else s) 0 ans.(matpno));; let yes = Array.init atpno (fun atp -> Array.fold_left (fun o i -> o + (if i = 5 then 1 else 0)) 0 ans.(atp));; let no = Array.init atpno (fun atp -> Array.fold_left (fun o i -> o + (if i = 4 then 1 else 0)) 0 ans.(atp));; let maybe = Array.init atpno (fun atp -> Array.fold_left (fun o i -> o + (if i = 3 then 1 else 0)) 0 ans.(atp));; let error = Array.init atpno (fun atp -> Array.fold_left (fun o i -> o + (if i = 2 then 1 else 0)) 0 ans.(atp));; let anyyes, anyno = ref 0, ref 0;; for f = 0 to fsno - 1 do let canayes, canano = ref false, ref false in for a = 0 to atpno - 1 do if ans.(a).(f) = 5 then canayes := true else if ans.(a).(f) = 4 then canano := true done; (if !canayes then incr anyyes); (if !canano then incr anyno); done;; let addl e l = if List.mem e l then l else e :: l;; let uniq = Array.create atpno 0;; for f = 0 to fsno - 1 do let conf1, conf2 = ref [], ref [] in for atp = 0 to atpno - 1 do if ans.(atp).(f) = 5 then begin let canayes = ref true in for a = 0 to atpno - 1 do if ans.(a).(f) = 4 then (conf1 := addl atp !conf1; conf2 := addl a !conf2) else if a <> atp && ans.(a).(f) = 5 then canayes := false else () done; if !canayes then (uniq.(atp) <- uniq.(atp) + 1; print_endline ("Uniq: " ^ atps.(atp) ^ " : " ^ fs.(f))) end done; if !conf1 <> [] then Printf.printf "Conflict: %i Yes: %s No: %s\n" f (String.concat "," (List.map (fun a -> atps.(a)) !conf1)) (String.concat "," (List.map (fun a -> atps.(a)) !conf2)) done;; let sotac = Array.create atpno 0.;; let counter_sotac = false;; for f = 0 to fsno - 1 do let sum = ref 0 in for atp = 0 to atpno - 1 do if ans.(atp).(f) = 5 || (counter_sotac && ans.(atp).(f) = 4) then incr sum; done; let factor = if !sum = 0 then 0. else 1. /. (float_of_int !sum) in for atp = 0 to atpno - 1 do if ans.(atp).(f) = 5 || (counter_sotac && ans.(atp).(f) = 4) then sotac.(atp) <- sotac.(atp) +. factor done done;; let sotacavg = Array.init atpno (fun i -> if yes.(i) = 0 then 0. else sotac.(i) /. (float_of_int (yes.(i) + no.(i))));; let sum2 a1 a2 = let rec sumi acc n = if n = fsno then acc else sumi (if a1.(n) > 4 || a2.(n) > 4 then 1 + acc else acc) (n + 1) in sumi 0 0;; let sum3 a1 a2 a3 = let rec sumi acc n = if n = fsno then acc else sumi (if a1.(n) > 4 || a2.(n) > 4 || a3.(n) > 4 then 1 + acc else acc) (n + 1) in sumi 0 0;; let suml l = let rec sumi acc n = if n = fsno then acc else sumi (if List.fold_left (fun sofar a -> sofar || a.(n) > 4) false l then 1+acc else acc) (n + 1) in sumi 0 0;; let update1 a a1 = let rec ui n = if n = fsno then () else ( (if a1.(n) > 4 then a.(n) <- 5); ui (n + 1)) in ui 0;; let update2 a a1 a2 = let rec ui n = if n = fsno then () else ( (if a1.(n) > 4 || a2.(n) > 4 then a.(n) <- 5); ui (n + 1)) in ui 0;; let arraymaxes f a = let cm = ref 0 and ci = ref [] in for i = 0 to Array.length a - 1 do let fa = f a.(i) in if fa > !cm then (ci := [i]; cm := fa) else if fa = !cm then ci := i :: !ci done; (!ci, !cm);; let current = Array.create fsno 0;; let sofar = ref 0;; let greed_reset () = Array.fill current 0 (Array.length current) 0; sofar := 0;; let id x = x;; let greed_add1 () = let sums = Array.init atpno (fun i -> sum2 current ans.(i)) in let (is, s) = arraymaxes id sums in if s <= !sofar then raise Exit; let a = try List.hd is with Failure _ -> failwith "empty!!!" in let alts = List.tl is in sofar := s; update1 current ans.(a); ((a, alts), s);; let greed_add2 () = let sums = Array.init (atpno * atpno) (fun i -> let a1 = i / atpno and a2 = i mod atpno in sum3 current ans.(a1) ans.(a2)) in let (is, s) = arraymaxes id sums in if s <= !sofar then raise Exit; let is = List.map (fun i -> (i / atpno, i mod atpno)) is in let ((a1, a2) as a) = try List.hd is with Failure _ -> failwith "empty!!!" in let alts = List.tl is in sofar := s; update2 current ans.(a1) ans.(a2); ((a, alts), s);; let greed_add2m () = let sums = Array.init (atpno * atpno) (fun i -> let a1 = i / atpno and a2 = i mod atpno in sum3 current ans.(a1) ans.(a2)) in let (is, s) = arraymaxes id sums in if s <= !sofar then raise Exit; let is = setify (List.concat (List.map (fun i -> [i / atpno; i mod atpno]) is)) in let sums = Array.of_list (List.map (fun i -> (i, sum2 current ans.(i))) is) in let (is, s) = arraymaxes snd sums in let a = fst (sums.(try List.hd is with Failure _ -> failwith "empty!!!")) in sofar := s; update1 current ans.(a); (a, s);; let greed_del1 curlst = let sums = Array.of_list (List.map (fun i -> (i, suml (List.map (Array.get ans) (List.filter (fun j -> j <> i) curlst)))) curlst) in let (is, s) = arraymaxes snd sums in let a = fst (sums.(try List.hd is with Failure _ -> failwith "empty!!!")) in let nlst = (List.filter (fun j -> j <> a) curlst) in sofar := suml (List.map (Array.get ans) nlst); Array.fill current 0 (Array.length current) 0; List.iter (update1 current) (List.map (Array.get ans) nlst); ((a, nlst), !sofar);; Printf.eprintf "s%!";; let greed = ref [];; greed_reset ();; List.iter (fun i -> if i >= 0 then update1 current ans.(i); sofar := suml (List.map (Array.get ans) (i :: (List.map (fun i -> fst (fst i)) !greed))); greed := ((i, []), !sofar) :: !greed; ) fixgreed;; try while true do greed := (greed_add1 ()) :: !greed done with Exit -> ();; let greedy = Array.of_list (List.rev !greed);; Printf.eprintf "g%!";; let name_comp n i = try List.nth (List.rev (Str.split dash_rxp atps.(i))) n with _ -> "";; let rec interp_sort i = function [] | "-" :: _ -> [Printf.sprintf "%010i" i] | "p" :: t -> atps.(i) :: interp_sort i t (* | "g" :: t -> Printf.sprintf "%010i" (1000000000 - (snd (fst greedy.(i)))) :: interp_sort i t*) | "y" :: t -> Printf.sprintf "%010i" (1000000000 - yes.(i)) :: interp_sort i t | "n" :: t -> Printf.sprintf "%010i" (1000000000 - no.(i)) :: interp_sort i t | "s" :: t -> Printf.sprintf "%09.5f" (1000000.0 -. sotac.(i)) :: interp_sort i t | n :: t -> let n = int_of_string n in name_comp n i :: (interp_sort i t) let sort_atp = Array.init atpno (fun i -> (i, interp_sort i sortmode));; Array.sort (fun a b -> compare (snd a) (snd b)) sort_atp;; let proc a b = if b = 0 then "?" else try Printf.sprintf "%.3f" ((100. *. float_of_int a) /. (float_of_int b)) with _ -> "....";; let oc = open_out "statistics.html";; Printf.fprintf oc "\n\n";; let print_table oc l = os oc ""; List.iter (fun (h, _, _) -> os oc "") l; os oc "\n"; for i = 0 to atpno - 1 do os oc ""; let a = fst (sort_atp.(i)) in List.iter (fun (_, (c, v), _) -> os oc "") l; os oc "\n" done; os oc ""; List.iter (fun (_, _, t) -> os oc "") l; os oc "\n
"; os oc h; os oc "
"; os oc (v a); os oc "
"; os oc t; os oc "
\n" ;; print_table oc [ ("Str", ("", name_comp 2), "any"); ("Predict", ("", name_comp 1), "any"); ("PrArg", ("", name_comp 0), ""); ("Thm%", ("yes", fun a -> proc yes.(a) pps.(a)), proc !anyyes fsno); ("CoS%", ("no", fun a -> proc no.(a) pps.(a)), proc !anyno fsno); ("Uniq", ("time", fun a -> string_of_int uniq.(a)), ""); ("ST⌀", ("time", fun a -> Printf.sprintf "%.3f" sotacavg.(a)), ""); ("STΣ", ("time", fun a -> Printf.sprintf "%.2f" sotac.(a)), ""); ("Thm", ("yes", fun a -> string_of_int yes.(a)), string_of_int !anyyes); ("CoS", ("no", fun a -> string_of_int no.(a)), string_of_int !anyno); ("Maybe", ("maybe", fun a -> string_of_int maybe.(a)), ""); ("Empty", ("timeout", fun a -> string_of_int (pps.(a) - yes.(a) - no.(a) - maybe.(a) - error.(a))),""); ("Err", ("error", fun a -> if error.(a) = 0 then "" else string_of_int error.(a)), ""); ("Found", ("time", fun a -> string_of_int pps.(a)), string_of_int fsno) ];; os oc "\n";; let greed = ref [];; if greed2 then begin greed_reset (); try while true do let (((a1,a2), _), s) = greed_add2 () in greed := s :: (-1) :: !greed; Printf.printf "Greed2: %s, %s\n" (Array.get atps a1) (Array.get atps a2) done with Exit -> () end let greedy2 = Array.of_list (List.rev !greed);; if greed2 then begin greed := []; greed_reset (); greed := snd (greed_add1 ()) :: !greed; try while true do let (_, s) = greed_add2 () in greed := s :: (-1) :: !greed done with Exit -> () end let greedy2a = Array.of_list (List.rev !greed);; if greed2 then begin let nos = ref [] in greed := []; greed_reset (); let (((a1, a2), _), s) = greed_add2 () in greed := s :: (-1) :: !greed; nos := a1 :: a2 :: !nos; try while true do let sum = !sofar in let ((_, nnos), _) = greed_del1 !nos in nos := nnos; let (((a1, a2), _), s) = greed_add2 () in nos := a1 :: a2 :: !nos; if s = sum then raise Exit; greed := s :: !greed done with Exit -> () end let greedym1p2 = Array.of_list (List.rev !greed);; if greed2 then begin greed := []; greed_reset (); try while true do let (a, s) = greed_add2m () in greed := s :: !greed done with Exit -> () end let greedy2m = Array.of_list (List.rev !greed);; Printf.fprintf oc "

Greedy sequence

\n";; try for i = 0 to Array.length greedy - 1 do let ((a, alt), m) = greedy.(i) in let alt5s = String.concat " = " (List.map (Array.get atps) (cut_list [] 3 alt)) in let alts = if alt = [] then "" else if List.length alt > 3 then "= " ^ alt5s ^ " = ... (" ^ (string_of_int (List.length alt)) ^ ")" else "= " ^ alt5s in let g2 = if i < Array.length greedy2 && greedy2.(i) >= 0 then string_of_int greedy2.(i) else "" in let g2a = if i < Array.length greedy2a && greedy2a.(i) >= 0 then string_of_int greedy2a.(i) else "" in let g3 = if i < Array.length greedym1p2 && greedym1p2.(i) >= 0 then string_of_int greedym1p2.(i) else "" in let gm = if i < Array.length greedy2m && greedy2m.(i) >= 0 then string_of_int greedy2m.(i) else "" in Printf.fprintf oc "\n" atps.(a) (proc m fsno) m g2 g2a g3 gm alts; if m = !anyyes then raise Exit else () done with Exit -> ();; os oc "
ProverSum%%SumG+2G1+2G-1+2G+2MAlt
%s%s%i%s%s%s%s%s
\n";; close_out oc;; coqhammer-1.3.2-8.20/eval/tools/utils.ml000066400000000000000000000123261471571225200176510ustar00rootroot00000000000000let runline s = let ic = Unix.open_process_in s in let ret = input_line ic in close_in ic; ret;; let uniq l = let rec uniq2 acc = function x::(y::_ as t) -> uniq2 (if Stdlib.compare x y = 0 then acc else x :: acc) t | [x] -> List.rev (x :: acc) | [] -> List.rev acc in uniq2 [] l;; (*let rec uniq = function (x::(y::_ as t) as l) -> let t' = uniq t in if compare x y = 0 then t' else if t'==t then l else x::t' | l -> l;;*) let setify l = uniq (List.sort compare l);; let file_iter fname fn = let ic = try open_in fname with Sys_error _ -> failwith ("file_iter: "^fname) in let next = ref 0 in let rec suck_lines () = fn !next (input_line ic); incr next; suck_lines () in try suck_lines () with End_of_file -> close_in ic;; let os = output_string;; let rec oiter oc fn sep = function [] -> () | [e] -> fn e | h :: t -> fn h; os oc sep; oiter oc fn sep t;; let cutoff = 5;; let stable_sort cmp a lb rb = let merge src1ofs src1len src2 src2ofs src2len dst dstofs = let src1r = src1ofs + src1len and src2r = src2ofs + src2len in let rec loop i1 s1 i2 s2 d = if cmp s1 s2 <= 0 then begin Array.set dst d s1; let i1 = i1 + 1 in if i1 < src1r then loop i1 (Array.get a i1) i2 s2 (d + 1) else Array.blit src2 i2 dst (d + 1) (src2r - i2) end else begin Array.set dst d s2; let i2 = i2 + 1 in if i2 < src2r then loop i1 s1 i2 (Array.get src2 i2) (d + 1) else Array.blit a i1 dst (d + 1) (src1r - i1) end in loop src1ofs (Array.get a src1ofs) src2ofs (Array.get src2 src2ofs) dstofs; in let isortto srcofs dst dstofs len = for i = 0 to len - 1 do let e = (Array.get a (srcofs + i)) in let j = ref (dstofs + i - 1) in while (!j >= dstofs && cmp (Array.get dst !j) e > 0) do Array.set dst (!j + 1) (Array.get dst !j); decr j; done; Array.set dst (!j + 1) e; done; in let rec sortto srcofs dst dstofs len = if len <= cutoff then isortto srcofs dst dstofs len else begin let l1 = len / 2 in let l2 = len - l1 in sortto (srcofs + l1) dst (dstofs + l1) l2; sortto srcofs a (srcofs + l2) l1; merge (srcofs + l2) l1 dst (dstofs + l1) l2 dst dstofs; end; in let l = rb - lb + 1 in if l <= cutoff then isortto lb a lb l else begin let l1 = l / 2 in let l2 = l - l1 in let t = Array.make l2 (Array.get a lb) in sortto (lb + l1) t 0 l2; sortto lb a (lb + l2) l1; merge (lb + l2) l1 t 0 l2 a lb; end; ;; let pivot a l r = let i = ref l and j = ref (r - 1) and p = snd a.(r) in while !i < !j do while snd a.(!i) >= p && !i < r do incr i done; while snd a.(!j) <= p && !j > l do decr j done; if !i < !j then (let t = a.(!i) in a.(!i) <- a.(!j); a.(!j) <- t) done; if snd a.(!i) < p then (let t = a.(!i) in a.(!i) <- a.(r); a.(r) <- t); !i;; let rec qsort a l r upto = if upto > r - l then stable_sort (fun a b -> compare (snd b) (snd a)) a l r else if upto > 0 && l < r then let p = pivot a l r in qsort a l (p - 1) upto; qsort a (p + 1) r (upto + l - p - 1); else ();; let qsort a upto = qsort a 0 (Array.length a - 1) upto;; exception Bottom of int;; let heapsort compare bound a = let maxson l i = let i31 = i+i+i+1 in let x = ref i31 in if i31+2 < l then begin if compare (Array.get a i31) (Array.get a (i31+1)) < 0 then x := i31+1; if compare (Array.get a !x) (Array.get a (i31+2)) < 0 then x := i31+2; !x end else if i31+1 < l && compare (Array.get a i31) (Array.get a (i31+1)) < 0 then i31+1 else if i31 < l then i31 else raise (Bottom i) in let rec trickledown l i e = let j = maxson l i in if compare (Array.get a j) e > 0 then begin Array.set a i (Array.get a j); trickledown l j e; end else begin Array.set a i e; end; in let rec trickle l i e = try trickledown l i e with Bottom i -> Array.set a i e in let rec bubbledown l i = let j = maxson l i in Array.set a i (Array.get a j); bubbledown l j in let bubble l i = try bubbledown l i with Bottom i -> i in let rec trickleup i e = let father = (i - 1) / 3 in assert (i <> father); if compare (Array.get a father) e < 0 then begin Array.set a i (Array.get a father); if father > 0 then trickleup father e else Array.set a 0 e; end else begin Array.set a i e; end; in let l = Array.length a in for i = (l + 1) / 3 - 1 downto 0 do trickle l i (Array.get a i); done; for i = l - 1 downto max 2 (l - bound) do let e = (Array.get a i) in Array.set a i (Array.get a 0); trickleup (bubble i 0) e; done; if l > 1 then (let e = (Array.get a 1) in Array.set a 1 (Array.get a 0); Array.set a 0 e); ;; let rec cut_list acc n = function [] -> List.rev acc | h :: t -> if n = 0 then List.rev acc else cut_list (h :: acc) (n - 1) t;; let list_to_hash exp l = let h = Hashtbl.create exp in List.iter (fun e -> Hashtbl.add h e ()) l; h ;; (* Generate the (inclusive) sequence [l, .., u]. *) let rec fromto l u = if l > u then [] else l :: fromto (l+1) u let string_begins_with s1 s2 = try String.sub s1 0 (String.length s2) = s2 with _ -> false coqhammer-1.3.2-8.20/examples/000077500000000000000000000000001471571225200157025ustar00rootroot00000000000000coqhammer-1.3.2-8.20/examples/euclidean_division.v000066400000000000000000000120331471571225200217250ustar00rootroot00000000000000(* This file demonstrates the use of the `hammer` tactic to find lemmas about real number in the standard library. All tactics with the `use:` option have been obtained by invoking `hammer`. *) (* From Hammer Require Import Hammer. *) From Hammer Require Import Tactics. Require Import Reals. Require Import Lra. Local Open Scope Z_scope. Local Open Scope R_scope. Lemma euclidean_division : forall x y:R, y <> 0 -> exists k : Z, (exists r : R, x = IZR k * y + r /\ 0 <= r < Rabs y). Proof. unfold not; intros x y H. assert (H0: y > 0 \/ y <= 0). { hecrush use: @Rtotal_order unfold: Rle. } destruct H0 as [H0|H0]. - pose (k := (up (x / y) - 1)%Z). exists k. exists (x - IZR k * y). assert (HH: IZR k = IZR (up (x / y)) - 1). { assert (IZR k = IZR (up (x / y)) - IZR 1%Z). { qauto use: @Z_R_minus. } sauto. } rewrite HH; clear HH. clear k. split. + qauto use: RIneq.Rplus_minus. + assert (HH: x - (IZR (up (x / y)) - 1) * y = x - IZR (up (x / y)) * y + y) by lra. rewrite HH; clear HH. split. * assert (IZR (up (x / y)) * y <= y + x). { assert (IZR (up (x / y)) <= 1 + (x / y)). { generalize (archimed (x / y)); sintuition. assert (IZR (up (x / y)) - (x / y) + (x / y) <= 1 + (x / y)). { qauto use: @Rplus_le_compat_r. } qauto use: Rplus_opp_l, Rplus_assoc, Rplus_0_r unfold: Rdefinitions.Rminus. } assert (IZR (up (x / y)) * y <= (1 + x / y) * y) by sauto. assert (IZR (up (x / y)) * y <= y + ((x / y) * y)). { qauto use: @Rmult_1_l, @Rmult_plus_distr_r. } hfcrush use: @Rmult_1_r, @Rmult_assoc, @Rinv_l_sym unfold: Rdiv. } lra. * assert (IZR (up (x / y)) * y > x). { assert (IZR (up (x / y)) > x / y). { hauto use: @archimed. } assert (IZR (up (x / y)) * y > (x / y) * y). { hauto use: @Rmult_gt_compat_r. } hfcrush use: @Rmult_1_r, @Rmult_assoc, @Rmult_comm, @Rinv_r_sym unfold: Rdiv. } assert (HH: Rabs y = y). { (* Unset Hammer CVC4. hammer. *) (* If you get an unreconstructible proof, it might help to disable the prover which found it. *) hauto ered: off use: @Rlt_asym unfold: Rabs, Rgt. } rewrite HH; clear HH. lra. - pose (k := (1 - up (x / -y))%Z). exists k. exists (x - IZR k * y). assert (HH: IZR k = 1 - IZR (up (x / -y))). { assert (IZR k = IZR 1 - IZR (up (x / -y))). { hauto ered: off use: @Z_R_minus unfold: Rminus, BinIntDef.Z.sub, Rdiv. } sauto. } rewrite HH; clear HH. clear k. split. + qauto use: @Rplus_minus. + assert (HH: x - (1 - IZR (up (x / - y))) * y = x - y + IZR (up (x / -y)) * y) by lra. rewrite HH; clear HH. split. * assert (IZR (up (x / -y)) * y >= y - x). { assert (IZR (up (x / -y)) <= 1 + (x / -y)). { generalize (archimed (x / -y)); sintuition. assert (IZR (up (x / -y)) - (x / -y) + (x / -y) <= 1 + (x / -y)). { hauto use: @Rplus_comm, @Rplus_le_compat_l. } hcrush use: @Rplus_opp_l, @Rplus_assoc, @Rplus_0_r unfold: Rminus, Rmax. } assert (y < 0) by sauto. assert (IZR (up (x / - y)) * y >= y + (x / - y) * y). { assert (IZR (up (x / - y)) * (-y) <= (1 + (x / - y)) * (-y)). { hauto use: @Ropp_0_ge_le_contravar, @Rmult_le_compat_r, @RIneq.Rle_ge. } assert (HH: IZR (up (x / - y)) * (-y) = - (IZR (up (x / - y)) * y)) by lra. rewrite HH in *; clear HH. assert (HH: (1 + (x / - y)) * (-y) = - (y + (x / -y) * y)) by lra. rewrite HH in *; clear HH. hfcrush use: @Rle_ge, @Ropp_le_cancel unfold: Rle, Rge, Rgt. } assert (HH: y + x / - y * y = y - x). { assert (x / - y * - y = x). { assert (HH1: - y > 0) by lra. assert (HH2: forall u, u <> 0 -> (x / u) * u = x). { hfcrush use: @Rinv_l_sym, @Rmult_1_r, @Rmult_assoc unfold: Rdiv. } (* Unset Hammer CVC4. hammer. *) qauto use: @Ropp_gt_cancel, @atan_right_inv, @Rgt_not_eq unfold: atan, Rdiv. } qauto use: @Ropp_involutive, @Ropp_mult_distr_r_reverse unfold: Rminus. } rewrite HH in *; clear HH. sauto. } lra. * assert (HH: Rabs y = -y). { qauto use: @Rabs_left1. } rewrite HH; clear HH. assert (IZR (up (x / -y)) * y < -x). { assert (IZR (up (x / -y)) > x / -y). { hfcrush use: @archimed. } assert (IZR (up (x / -y)) * -y > (x / -y) * -y). { hauto ered: off use: @Rlt_irrefl, @Rmult_gt_compat_r, @Rabs_pos, @Rabs_pos_lt, @Rle_lt_trans unfold: Rabs, Rle, Rgt. } assert (HH: x / - y * - y = x). { assert (- y <> 0). { hauto use: @Rplus_0_r, @Rplus_opp_r. } assert (forall u, u <> 0 -> (x / u) * u = x). { hfcrush use: @Rmult_1_r, @Rinv_l_sym, @Rmult_assoc unfold: Rdiv. } sauto. } rewrite HH in *; clear HH. lra. } lra. Qed. coqhammer-1.3.2-8.20/examples/hammer_tests.v000066400000000000000000000203441471571225200205670ustar00rootroot00000000000000(* This file showcases hammer usage. Most of the problems here are simple modifications of lemmas present in the standard library (e.g. by changing the order of quantifiers or premises, duplicating some premises, changing function argument order, changing the conclusion to an equivalent one, etc) or a combination of a few lemmas. The calls to the "hammer" tactic are left here only for illustrative purposes. Because the success of the hammer is not guaranteed to be reproducible, in the final scripts "hammer" should be replaced with an appropriate reconstruction tactic. *) From Hammer Require Import Hammer. (*********************************************************************************************) (* Lemma lem_false : False. Proof. hammer. Qed.*) (* Lemma lem_classic : forall P : Prop, P \/ ~P. Proof. hammer. Qed.*) Require Import Arith. (* disable the preliminary sauto tactic *) Set Hammer SAutoLimit 0. Lemma lem_1 : le 1 2. hammer. Restart. scongruence use: Nat.lt_0_2 unfold: lt. Qed. Lemma lem_2 : forall n : nat, Nat.Odd n \/ Nat.Odd (n + 1). hammer. Restart. hauto lq: on use: Nat.Even_or_Odd, Nat.add_1_r, Nat.Odd_succ. Qed. Lemma lem_2_1 : forall n : nat, Nat.Even n \/ Nat.Even (n + 1). hammer. Restart. hauto lq: on use: Nat.add_1_r, Nat.Even_or_Odd, Nat.Even_succ. Qed. Lemma lem_3 : le 2 3. hammer. Restart. srun eauto use: Nat.le_succ_diag_r unfold: Init.Nat.two. Qed. Lemma lem_4 : le 3 10. hammer. Restart. sfirstorder use: Nat.nle_succ_0, Nat.le_gt_cases, Nat.lt_succ_r, Nat.succ_le_mono, Nat.log2_up_2 unfold: Init.Nat.two. Qed. Lemma mult_1 : forall m n k : nat, m * n + k = k + n * m. Proof. hammer. Restart. scongruence use: Nat.mul_comm, Nat.add_comm. Qed. Lemma lem_rew : forall m n : nat, 1 + n + m + 1 = m + 2 + n. Proof. hammer. Restart. strivial use: Nat.add_comm, Nat.add_1_r, Nat.add_shuffle1, Nat.add_assoc. Qed. Lemma lem_pow : forall n : nat, 3 * 3 ^ n = 3 ^ (n + 1). Proof. hammer. Restart. qauto use: Nat.pow_succ_r, Nat.le_0_l, Nat.add_1_r. Qed. Require Coq.Reals.RIneq. Require Coq.Reals.Raxioms. Require Coq.Reals.Rtrigo1. Lemma cos_decreasing_1 : forall y x : Rdefinitions.R, Rdefinitions.Rlt x y -> Rdefinitions.Rle x Rtrigo1.PI -> Rdefinitions.Rge y Rdefinitions.R0 -> Rdefinitions.Rle y Rtrigo1.PI -> Rdefinitions.Rge x Rdefinitions.R0 -> Rdefinitions.Rlt (Rtrigo_def.cos y) (Rtrigo_def.cos x). Proof. (* hammer. Restart. *) hauto using (@Reals.Rtrigo1.cos_decreasing_1, @Reals.RIneq.Rge_le). Qed. Require ZArith.BinInt. Lemma max_lub : forall m p k n : BinNums.Z, BinInt.Z.ge p m -> BinInt.Z.le n p -> BinInt.Z.le (BinInt.Z.max n m) p. Proof. hammer. Restart. srun eauto use: BinInt.Z.max_lub, BinInt.Z.ge_le. Qed. Require Reals. Lemma lem_iso : forall x1 y1 x2 y2 theta : Rdefinitions.R, Rgeom.dist_euc x1 y1 x2 y2 = Rgeom.dist_euc (Rgeom.xr x1 y1 theta) (Rgeom.yr x1 y1 theta) (Rgeom.xr x2 y2 theta) (Rgeom.yr x2 y2 theta). Proof. hammer. Restart. scongruence use: Rgeom.isometric_rotation. Qed. Require Import List. Lemma lem_lst : forall {A} (x : A) l1 l2 (P : A -> Prop), In x (l1 ++ l2) -> (forall y, In y l1 -> P y) -> (forall y, In y l2 -> P y) -> P x. Proof. hammer. Restart. qauto use: in_app_iff. (* `firstorder with datatypes' does not work *) Qed. Lemma lem_lst2 : forall {A} (y1 y2 y3 : A) l l' z, In z l \/ In z l' -> In z (y1 :: y2 :: l ++ y3 :: l'). Proof. hammer. Restart. hauto lq: on use: in_app_iff, in_or_app, not_in_cons, in_cons, Add_in unfold: app. (* `firstorder with datatypes' does not work *) Qed. Lemma lem_lst3 : forall {A} (l : list A), length (tl l) <= length l. Proof. hammer. Restart. qauto use: le_S, Nat.le_0_l, le_n unfold: tl, length. Qed. Require NArith.Ndec. Lemma Nleb_alt : forall b a c : BinNums.N, Ndec.Nleb b c = BinNat.N.leb b c /\ Ndec.Nleb a b = BinNat.N.leb a b. Proof. hammer. Restart. srun eauto use: Ndec.Nleb_alt. Qed. Require NArith.BinNat. Lemma setbit_iff : forall m a n : BinNums.N, n = m \/ true = BinNat.N.testbit a m <-> BinNat.N.testbit (BinNat.N.setbit a n) m = true. Proof. hammer. Restart. hfcrush use: BinNat.N.setbit_iff. Qed. Lemma in_int_p_Sq : forall r p q a : nat, a >= 0 -> Between.in_int p (S q) r -> Between.in_int p q r \/ r = q \/ a = 0. Proof. hammer. Restart. hauto lq: on use: in_int_p_Sq. Qed. Require Reals.Rminmax. Lemma min_spec_1 : forall n m : Rdefinitions.R, (Rdefinitions.Rle m n /\ Rbasic_fun.Rmin m m = m) \/ (Rdefinitions.Rlt n m /\ Rbasic_fun.Rmin m n = n). Proof. hammer. Restart. hauto use: RIneq.Rnot_le_lt unfold: Rbasic_fun.Rmin. Qed. Lemma min_spec_2 : forall n m : Rdefinitions.R, (Rdefinitions.Rle m n /\ Rbasic_fun.Rmin m n = m) \/ (Rdefinitions.Rlt n m /\ Rbasic_fun.Rmin m n = n). Proof. hammer. Restart. hauto use: RIneq.Rnot_le_lt unfold: Rbasic_fun.Rmin. Qed. Lemma incl_app : forall (A : Type) (n l m : list A), List.incl l n /\ List.incl m n -> List.incl (l ++ m) n. Proof. hammer. Restart. strivial use: incl_app. Qed. Require Reals.Rpower. Lemma exp_Ropp : forall x y : Rdefinitions.R, Rdefinitions.Rinv (Rtrigo_def.exp x) = Rtrigo_def.exp (Rdefinitions.Ropp x). Proof. hammer. Restart. srun eauto use: Rpower.exp_Ropp. Qed. Lemma lem_lst_1 : forall (A : Type) (l l' : list A), List.NoDup (l ++ l') -> List.NoDup l. Proof. (* The hammer can't do induction. If induction is necessary to carry out the proof, then one needs to start the induction manually. *) induction l'. - hammer. Undo. scongruence use: app_nil_end. - hammer. Undo. srun eauto use: NoDup_remove_1. Qed. Lemma NoDup_remove_2 : forall (A : Type) (a : A) (l' l : list A), List.NoDup (l ++ a :: l') -> ~ List.In a (l ++ l') /\ List.NoDup (l ++ l') /\ List.NoDup l. Proof. hammer. Restart. strivial use: lem_lst_1, NoDup_remove. Qed. Lemma leb_compare2 : forall m n : nat, PeanoNat.Nat.leb n m = true <-> (PeanoNat.Nat.compare n m = Lt \/ PeanoNat.Nat.compare n m = Eq). Proof. (* hammer. Restart. *) (* Sometimes the tactics cannot reconstruct the goal, but the returned dependencies may still be used to create the proof semi-manually. *) assert (forall c : Datatypes.comparison, c = Eq \/ c = Lt \/ c = Gt) by sauto inv: Datatypes.comparison. hauto erew: off use: Compare_dec.leb_compare. Qed. Lemma leb_1 : forall m n : nat, PeanoNat.Nat.leb m n = true <-> m <= n. Proof. hammer. Restart. srun eauto use: Nat.leb_le, Nat.leb_nle, leb_correct, leb_complete. Qed. Lemma leb_2 : forall m n : nat, PeanoNat.Nat.leb m n = false <-> m > n. Proof. hammer. Restart. srun eauto use: leb_iff_conv, leb_correct_conv unfold: gt. Qed. Lemma incl_appl_1 : forall (A : Type) (l m n : list A), List.incl l n -> List.incl l (n ++ m) /\ List.incl l (m ++ n) /\ List.incl l (l ++ l). Proof. hammer. Restart. strivial use: incl_appl, incl_refl, incl_appr. Qed. Lemma in_int_lt2 : forall p q r : nat, Between.in_int p q r -> q >= p /\ r >= p /\ r <= q. Proof. hammer. Restart. sfirstorder use: Nat.lt_le_incl, in_int_lt unfold: ge, in_int. Qed. Lemma nat_compare_eq : forall n m : nat, PeanoNat.Nat.compare n m = Eq <-> n = m. Proof. hammer. Restart. srun eauto use: Nat.compare_eq_iff. Qed. Lemma Forall_1 : forall (A : Type) (P : A -> Prop) (a : A), forall (l l' : list A), List.Forall P l /\ List.Forall P l' /\ P a -> List.Forall P (l ++ a :: l'). Proof. induction l. - hammer. Undo. strivial use: app_nil_l, Forall_cons. - (* hammer. Undo. *) sauto use: Forall_cons. Restart. induction l; qsimpl. Qed. (* Neither the base case nor the inductive step may be solved using 'firstorder with datatypes'. *) Lemma Forall_impl : forall (A : Type) (P : A -> Prop), forall l : list A, List.Forall P l -> List.Forall P (l ++ l). Proof. induction l. - hammer. Undo. srun eauto use: app_nil_end. - hammer. Undo. qauto use: Forall_inv, Forall_inv_tail, Forall_1. Qed. Lemma minus_neq_O : forall n i:nat, (i < n) -> (n - i) <> 0. Proof. hammer. Undo. srun eauto use: Nat.sub_gt. Qed. coqhammer-1.3.2-8.20/examples/sqrt2_irrational.v000066400000000000000000000047121471571225200213740ustar00rootroot00000000000000(* This file contains a proof of the fact that the square root of 2 is irrational. *) (* From Hammer Require Import Hammer. *) From Hammer Require Import Tactics. Require Import Reals. Require Import Arith. Require Import Wf_nat. Require Import Even. Require Import Lia. Lemma lem_0 : forall n m, n <> 0 -> m * m = 2 * n * n -> m < 2 * n. Proof. intros n m H H0. destruct (lt_dec m (2 * n)) as [|H1]; try strivial. exfalso. assert (m >= 2 * n) by lia. clear H1. assert (m * m >= 2 * n * (2 * n)). { assert (m * m >= 2 * n * m). { hauto use: @Nat.le_0_l, @Nat.mul_le_mono_nonneg_r unfold: ge. } assert (2 * n * m >= 2 * n * (2 * n)). { hauto use: @Nat.le_0_l, @Nat.mul_le_mono_nonneg_l unfold: ge. } eauto with arith. } sauto. Qed. Lemma lem_main : forall n m, n * n = 2 * m * m -> m = 0. Proof. intro n; pattern n; apply lt_wf_ind; clear n. intros n H m H0. destruct (Nat.eq_dec n 0) as [H1|H1]; subst. - sauto. - destruct (even_odd_cor n) as [k HH]. destruct HH as [H2|H2]; subst. + assert (2 * k * k = m * m) by lia. assert (m < 2 * k). { qauto use: @Nat.mul_0_r, @lem_0. } sauto. + sauto. Qed. Theorem thm_irrational : forall (p q : nat), q <> 0 -> sqrt 2 <> (INR p / INR q)%R. Proof. unfold not. intros p q H H0. assert (2 * q * q = p * p). { assert (((sqrt 2) ^ 2)%R = 2%R). { hauto use: @Rsqr_sqrt, @Rlt_R0_R2, @Rsqr_pow2 unfold: Rle. } assert (((INR p / INR q) ^ 2)%R = ((INR p / INR q) * (INR p / INR q))%R). { qauto use: @Rsqr_pow2 unfold: Rsqr. } assert (((INR p / INR q) * (INR p / INR q))%R = ((INR p * INR p) / (INR q * INR q))%R). { hauto use: @Rsqr_div, @not_0_INR. } assert (HH: 2%R = ((INR p * INR p) / (INR q * INR q))%R) by sauto. assert (INR q <> 0%R). { qauto use: @INR_not_0, @INR_eq. } assert (HH2: (2 * INR q * INR q)%R = (INR p * INR p)%R). { rewrite HH; rewrite Rmult_assoc. hfcrush use: @Rinv_l_sym, @Rmult_1_r, @Rmult_integral_contrapositive_currified, @Rmult_assoc unfold: Rsqr, Rdiv. } clear -HH2. assert (forall a b, INR a = INR b -> a = b). { qauto use: @INR_eq. } assert (INR (2 * q * q) = INR (p * p)). { assert (INR (p * p) = (INR p * INR p)%R). { hfcrush use: @mult_INR. } assert (INR (2 * q * q) = (2 * INR q * INR q)%R). { assert (INR (2 * q * q) = (INR 2 * INR q * INR q)%R). { hauto ered: off use: @mult_INR. } sauto. } sauto. } sauto. } sauto use: lem_main. Qed. coqhammer-1.3.2-8.20/examples/tutorial/000077500000000000000000000000001471571225200175455ustar00rootroot00000000000000coqhammer-1.3.2-8.20/examples/tutorial/README.md000066400000000000000000000012261471571225200210250ustar00rootroot00000000000000CoqHammer v1.3 tutorial Tutorial videos are available [here](https://www.youtube.com/watch?v=0c_utk9bVgU&list=PLXXF_svQE_b8ux7fJTL-XX2yjUhYSkYcb). The tutorial files should be read in the following order: 1. [sauto/isort.v](sauto/isort.v) 2. [sauto/isortb.v](sauto/isortb.v) 3. [sauto/itrev.v](sauto/itrev.v) 4. [sauto/order.v](sauto/order.v) 5. [sauto/msort.v](sauto/msort.v) 6. [sauto/imp.v](sauto/imp.v) 7. [sauto/exp.v](sauto/exp.v) 8. [hammer/demo.v](hammer/demo.v) 9. [hammer/gcd.v](hammer/gcd.v) See also a formalisation of various sorting algorithms with `sauto`: [https://github.com/lukaszcz/sortalgs](https://github.com/lukaszcz/sortalgs). coqhammer-1.3.2-8.20/examples/tutorial/hammer/000077500000000000000000000000001471571225200210165ustar00rootroot00000000000000coqhammer-1.3.2-8.20/examples/tutorial/hammer/demo.v000066400000000000000000000112021471571225200221250ustar00rootroot00000000000000(* "hammer" demo *) (* The "hammer" tactic works in three phases: *) (* 1. Machine-learning premise selection. *) (* 2. Translation to automated theorem provers (ATPs). *) (* 3. Proof search in the logic of Coq with the dependencies returned by the ATPs. *) (* CoqHammer uses classical first-order ATPs just to select the right dependencies. The goal must then be re-proven from scratch in the intuitionistic logic of Coq, using the dependencies returned by the ATPs. *) (* The target external tools of CoqHammer are general first-order ATPs, not SMT-solvers. CoqHammer can use some SMT-solvers because in practice they may often be used in the same way as general ATPs. But CoqHammer will never use any of the "modulo theory" features of SMT-solvers. Natural numbers, lists, etc., are not translated in any special way and the SMT-solvers will see them as uninterpreted data types. *) From Hammer Require Import Hammer. (* To use the Hammer module which contains the "hammer" tactic you need to install the full CoqHammer system: opam install coq-hammer Or from source: make && make install *) Hammer_version. Hammer_objects. Require Import Arith. Lemma lem_odd : forall n : nat, Nat.Odd n \/ Nat.Odd (n + 1). Proof. (* hammer. *) hauto lq: on use: Nat.Odd_succ, Nat.Even_or_Odd, Nat.add_1_r. Qed. Lemma lem_even : forall n : nat, Nat.Even n \/ Nat.Even (n + 1). Proof. (* predict 16. *) (* hammer. *) hauto lq: on use: Nat.add_1_r, Nat.Even_or_Odd, Nat.Even_succ. Qed. Lemma lem_pow : forall n : nat, 3 * 3 ^ n = 3 ^ (n + 1). Proof. Fail sauto. (* hammer. *) hauto lq: on use: Nat.pow_succ_r, Nat.le_0_l, Nat.add_1_r. Qed. Require List. Import List.ListNotations. Open Scope list_scope. Lemma lem_incl_concat : forall (A : Type) (l m n : list A), List.incl l n -> List.incl l (n ++ m) /\ List.incl l (m ++ n) /\ List.incl l (l ++ l). Proof. (* hammer. *) strivial use: List.incl_appr, List.incl_refl, List.incl_appl. Qed. Lemma lem_lst_1 : forall (A : Type) (l l' : list A), List.NoDup (l ++ l') -> List.NoDup l. Proof. (* The "hammer" tactic can't do induction. If induction is necessary to carry out the proof, then one needs to start the induction manually. *) induction l'. - (* hammer. *) scongruence use: List.app_nil_end. - (* hammer. *) srun eauto use: List.NoDup_remove_1. Qed. Require Import Sorting.Permutation. (* Lemma lem_perm_1 {A} : forall (x y : A) l1 l2 l3, Permutation l1 (y :: l2) -> Permutation (x :: l1 ++ l3) (y :: x :: l2 ++ l3). Proof. hammer. *) Lemma lem_perm_0 {A} : forall (x y : A) l1 l2 l3, Permutation l1 (y :: l2) -> Permutation (x :: l1 ++ l3) (x :: y :: l2 ++ l3). Proof. (* hammer. *) hauto lq: on drew: off use: Permutation_app, List.app_comm_cons, Permutation_refl, perm_skip. Qed. Lemma lem_perm_1 {A} : forall (x y : A) l1 l2 l3, Permutation l1 (y :: l2) -> Permutation (x :: l1 ++ l3) (y :: x :: l2 ++ l3). Proof. (* hammer. *) srun eauto use: @lem_perm_0, perm_skip, Permutation_Add, Permutation_trans, Permutation_sym, perm_swap unfold: app. Undo. (* Occasionally, some of the returned dependencies are not necessary. *) srun eauto use: @lem_perm_0, Permutation_trans, perm_swap. (* Undo. Set Hammer MinimizationThreshold 0. hammer. *) Qed. (* A general advice: use "hammer" to prove entire lemmas which are stated separately. Using "hammer" to prove subgoals in a larger proof is less effective. One reason is that the machine-learning premise selection can get confused by the presence of unnecessary hypotheses in the context. *) Lemma lem_perm_2 : forall (x : nat) l1 l2 l3, Permutation (x :: l1) l2 -> Permutation (x :: l3 ++ l1) (l3 ++ l2). Proof. (* hammer. *) (* If an ATP returns at least 8 dependencies, then "hammer" tries to automatically minimize the number of dependencies by repeatedly running the ATPs with the returned dependencies as long as some ATP returns fewer dependencies. *) srun eauto use: Permutation_app_head, Permutation_trans, Permutation_app_comm, Permutation_cons_app. Qed. Lemma lem_perm_3 : forall (x y : nat) l1 l2 l3, Permutation (x :: l1) l2 -> Permutation (x :: y :: l1 ++ l3) (y :: l2 ++ l3). Proof. (* hammer. *) srun eauto use: @lem_perm_1, Permutation_sym. Qed. Lemma lem_perm_4 : forall (x y : nat) l1 l2 l3, Permutation (x :: l1) l2 -> Permutation (x :: y :: l3 ++ l1) (y :: l3 ++ l2). Proof. (* hammer. *) intros. rewrite List.app_comm_cons. pattern (y :: l3 ++ l2). rewrite List.app_comm_cons. apply lem_perm_2; assumption. Qed. (* Lemma lem_classic : forall P : Prop, P \/ ~P. Proof. hammer. Qed.*) coqhammer-1.3.2-8.20/examples/tutorial/hammer/gcd.v000066400000000000000000000053351471571225200217500ustar00rootroot00000000000000From Hammer Require Import Tactics. From Hammer Require Import Hammer. (* for `hammer` *) Require Import Program. Require Import Arith. Require Import Lia. (* Is "d" a common divisor of "a" and "b"? *) Definition is_cd d a b := a mod d = 0 /\ b mod d = 0. (* Is "d" the greatest common divisor of "a" and "b"? *) Definition is_gcd d a b := is_cd d a b /\ forall d', is_cd d' a b -> d' <= d. Lemma lem_gcd_step : forall a b d, b <> 0 -> is_gcd d b (a mod b) -> is_gcd d a b. Proof. unfold is_gcd, is_cd. intros a b d Hb. sintuition. - destruct (Nat.eq_dec d 0) as [Hd|Hd]. + subst; reflexivity. + assert (Hc1: exists c1, b = d * c1). { (* hammer. *) strivial use: Nat.mod_divides. } assert (Hc2: exists c2, a mod b = d * c2). { (* hammer. *) strivial use: Nat.mod_divides. } assert (Hc3: exists c3, a = b * c3 + a mod b). { (* hammer. *) srun eauto use: Nat.div_mod. } clear -Hc1 Hc2 Hc3 Hd. destruct Hc1 as [c1 H1]. destruct Hc2 as [c2 H2]. destruct Hc3 as [c3 H3]. subst. rewrite H2 in H3. subst. assert (H: d * c1 * c3 + d * c2 = (c1 * c3 + c2) * d) by lia. rewrite H. auto using Nat.mod_mul. - enough ((a mod b) mod d' = 0) by auto. destruct (Nat.eq_dec d' 0) as [Hd|Hd]. + subst; reflexivity. + assert (Hc1: exists c1, b = d' * c1) by hauto use: Nat.mod_divides. assert (Hc2: exists c2, a = d' * c2) by hauto use: Nat.mod_divides. assert (Hc3: exists c3, a = b * c3 + a mod b). { exists (a / b); auto using Nat.div_mod. } clear -Hc1 Hc2 Hc3 Hd Hb. destruct Hc1 as [c1 H1]. destruct Hc2 as [c2 H2]. destruct Hc3 as [c3 H3]. subst. (* hammer. *) clear - Hb Hd. (* Coq.Arith.PeanoNat.Nat.mod_mul, Coq.Arith.PeanoNat.Nat.mul_mod_distr_l, Coq.Arith.PeanoNat.Nat.mul_comm *) rewrite Nat.mul_mod_distr_l; [| lia | lia ]. rewrite Nat.mul_comm. apply Nat.mod_mul; assumption. Qed. Program Fixpoint gcd (a b : nat) {measure b} : {d : nat | a + b > 0 -> is_gcd d a b} := match b with | 0 => a | _ => gcd b (a mod b) end. Next Obligation. unfold is_gcd, is_cd. sintuition. - (* hammer. *) sfirstorder use: Nat.mod_same. - (* hammer. *) (* time sauto. *) (* Set Hammer SAutoLimit 0. hammer. *) sfirstorder use: Nat.mod_0_l. - (* hammer. *) qauto use: Nat.add_pos_cases, Nat.le_gt_cases, Nat.mod_small, Nat.neq_0_lt_0. Qed. Next Obligation. (* hammer. *) srun eauto use: Nat.mod_upper_bound. Qed. Next Obligation. simpl_sigma. (* hammer. *) apply lem_gcd_step; [ lia | apply i; lia ]. Qed. Check gcd. Compute ` (gcd 2 3). Compute ` (gcd 5 15). Compute ` (gcd 20 15). Compute ` (gcd 2424 1542). coqhammer-1.3.2-8.20/examples/tutorial/sauto/000077500000000000000000000000001471571225200207005ustar00rootroot00000000000000coqhammer-1.3.2-8.20/examples/tutorial/sauto/exp.v000066400000000000000000000102731471571225200216660ustar00rootroot00000000000000(* Dependently typed expressions *) From Hammer Require Import Tactics. Require Import Program.Equality. (* for "depind" and "depelim" *) Require Import Arith. Require Import String. Inductive type := Nat | Bool | Prod (ty1 ty2 : type). Fixpoint tyeval (ty : type) : Type := match ty with | Nat => nat | Bool => bool | Prod ty1 ty2 => tyeval ty1 * tyeval ty2 end. Inductive expr : type -> Type := | Var : string -> expr Nat | Plus : expr Nat -> expr Nat -> expr Nat | Equal : expr Nat -> expr Nat -> expr Bool | Pair : forall {A B}, expr A -> expr B -> expr (Prod A B) | Fst : forall {A B}, expr (Prod A B) -> expr A | Snd : forall {A B}, expr (Prod A B) -> expr B | Const : forall A, tyeval A -> expr A | Ite : forall {A}, expr Bool -> expr A -> expr A -> expr A. Definition store := string -> nat. Fixpoint eval {A} (s : store) (e : expr A) : tyeval A := match e with | Var n => s n | Plus e1 e2 => eval s e1 + eval s e2 | Equal e1 e2 => eval s e1 =? eval s e2 | Pair e1 e2 => (eval s e1, eval s e2) | Fst e => fst (eval s e) | Snd e => snd (eval s e) | Const _ c => c | Ite b e1 e2 => if eval s b then eval s e1 else eval s e2 end. Definition simp_plus (e1 e2 : expr Nat) := match e1, e2 with | Const Nat n1, Const Nat n2 => Const Nat (n1 + n2) | _, Const Nat 0 => e1 | Const Nat 0, _ => e2 | _, _ => Plus e1 e2 end. Lemma lem_plus : forall s e1 e2, eval s (simp_plus e1 e2) = eval s e1 + eval s e2. Proof. time (depind e1; depelim e2; sauto). (* Undo. time (depind e1; depelim e2; sauto l: on). *) Qed. Lemma lem_plus' : forall s e1 e2, eval s (simp_plus e1 e2) = eval s e1 + eval s e2. Proof. Fail depind e1; sauto. time (depind e1; sauto dep: on). (* "dep: on" instructs "sauto" to use the "depelim" tactic for inversion. This may be slower and it will make your proof depend on axioms (equivalent to Uniqueness of Identity Proofs). *) Qed. Hint Rewrite lem_plus : simp_db. Definition simp_equal (e1 e2 : expr Nat) := match e1, e2 with | Const Nat n1, Const Nat n2 => Const Bool (n1 =? n2) | _, _ => Equal e1 e2 end. Lemma lem_equal : forall s e1 e2, eval s (simp_equal e1 e2) = (eval s e1 =? eval s e2). Proof. Fail depind e1; sauto. time (depind e1; sauto dep: on). Undo. time (depind e1; depelim e2; sauto). Qed. Hint Rewrite lem_equal : simp_db. Definition unpair_type (T : type) := option (match T with Prod A B => expr A * expr B | _ => unit end). Definition unpair {A B : type} (e : expr (Prod A B)) : option (expr A * expr B) := match e in expr T return unpair_type T with | Pair e1 e2 => Some (e1, e2) | _ => None end. Definition simp_fst {A B : type} (e : expr (Prod A B)) : expr A := match unpair e with | Some (e1, e2) => e1 | None => Fst e end. Lemma lem_fst {A B} : forall s (e : expr (Prod A B)), eval s (simp_fst e) = fst (eval s e). Proof. depind e; sauto. Qed. Hint Rewrite @lem_fst : simp_db. Definition simp_snd {A B : type} (e : expr (Prod A B)) : expr B := match unpair e with | Some (e1, e2) => e2 | None => Snd e end. Lemma lem_snd {A B} : forall s (e : expr (Prod A B)), eval s (simp_snd e) = snd (eval s e). Proof. depind e; sauto. Qed. Hint Rewrite @lem_snd : simp_db. Definition simp_ite {A} (e : expr Bool) (e1 e2 : expr A) : expr A := match e with | Const Bool true => e1 | Const Bool false => e2 | _ => Ite e e1 e2 end. Lemma lem_ite {A} : forall s e (e1 e2 : expr A), eval s (simp_ite e e1 e2) = if eval s e then eval s e1 else eval s e2. Proof. depind e; sauto. Qed. Hint Rewrite @lem_ite : simp_db. Fixpoint simp {A} (e : expr A) : expr A := match e with | Var n => Var n | Plus e1 e2 => simp_plus (simp e1) (simp e2) | Equal e1 e2 => simp_equal (simp e1) (simp e2) | Pair e1 e2 => Pair (simp e1) (simp e2) | Fst e => simp_fst (simp e) | Snd e => simp_snd (simp e) | Const t c => Const t c | Ite e e1 e2 => simp_ite (simp e) (simp e1) (simp e2) end. Lemma lem_simp {A} : forall s (e : expr A), eval s (simp e) = eval s e. Proof. time (depind e; sauto use: lem_plus, lem_equal, @lem_fst, @lem_snd, @lem_ite). Undo. time (depind e; sauto db: simp_db). Undo. time (depind e; simpl; autorewrite with simp_db; sauto). Qed. coqhammer-1.3.2-8.20/examples/tutorial/sauto/imp.v000066400000000000000000000313551471571225200216630ustar00rootroot00000000000000(* This file contains a definition of a simple imperative programming language together with its operational semantics and a definition of Hoare logic for it. Most definitions and lemma statements were translated into Coq from Isabelle/HOL statements present in the book: T. Nipkow, G. Klein, Concrete Semantics with Isabelle/HOL. This gives a rough idea of how the automation provided by CoqHammer compares to the automation available in Isabelle/HOL. *) From Hammer Require Import Tactics Reflect. Require Import String. Require Import Arith. Require Import Lia. Open Scope string_scope. Inductive aexpr := | Aval : nat -> aexpr | Avar : string -> aexpr | Aplus : aexpr -> aexpr -> aexpr | Aminus : aexpr -> aexpr -> aexpr. Coercion Aval : nat >-> aexpr. Notation "A +! B" := (Aplus A B) (at level 50). Notation "A -! B" := (Aminus A B) (at level 50). Notation "^ A" := (Avar A) (at level 40). Definition state := string -> nat. Fixpoint aval (s : state) (e : aexpr) := match e with | Aval n => n | Avar x => s x | Aplus x y => aval s x + aval s y | Aminus x y => aval s x - aval s y end. Inductive bexpr := | Bval : bool -> bexpr | Bnot : bexpr -> bexpr | Band : bexpr -> bexpr -> bexpr | Bless : aexpr -> aexpr -> bexpr. Coercion Bval : bool >-> bexpr. Notation "~! A" := (Bnot A) (at level 55). Notation "A &! B" := (Band A B) (at level 55). Notation "A b | Bnot e1 => negb (bval s e1) | Band e1 e2 => bval s e1 && bval s e2 | Bless a1 a2 => aval s a1 aexpr -> cmd | Seq : cmd -> cmd -> cmd | If : bexpr -> cmd -> cmd -> cmd | While : bexpr -> cmd -> cmd. Notation "A <- B" := (Assign A B) (at level 60). Notation "A ;; B" := (Seq A B) (at level 70). Notation "'If' A 'Then' B 'Else' C" := (If A B C) (at level 65). Notation "'While' A 'Do' B" := (While A B) (at level 65). Definition update (s : state) x v y := if string_dec x y then v else s y. Definition state_subst (s : state) (x : string) (a : aexpr) : state := (update s x (aval s a)). Notation "s [ x := a ]" := (state_subst s x a) (at level 5). (* Big-step operational semantics *) Inductive BigStep : cmd -> state -> state -> Prop := | NopSem : forall s, BigStep Nop s s | AssignSem : forall s x a, BigStep (x <- a) s s[x := a] | SeqSem : forall c1 c2 s1 s2 s3, BigStep c1 s1 s2 -> BigStep c2 s2 s3 -> BigStep (c1 ;; c2) s1 s3 | IfTrue : forall b c1 c2 s s', bval s b -> BigStep c1 s s' -> BigStep (If b Then c1 Else c2) s s' | IfFalse : forall b c1 c2 s s', negb (bval s b) -> BigStep c2 s s' -> BigStep (If b Then c1 Else c2) s s' | WhileFalse : forall b c s, negb (bval s b) -> BigStep (While b Do c) s s | WhileTrue : forall b c s1 s2 s3, bval s1 b -> BigStep c s1 s2 -> BigStep (While b Do c) s2 s3 -> BigStep (While b Do c) s1 s3. Notation "A >> B ==> C" := (BigStep A B C) (at level 80, no associativity). Lemma lem_big_step_deterministic : forall c s s1, c >> s ==> s1 -> forall s2, c >> s ==> s2 -> s1 = s2. Proof. time (induction 1; sauto brefl: on). Undo. time (induction 1; sauto lazy: on brefl: on). Undo. time (induction 1; sauto lazy: on quick: on brefl: on). Qed. (* Program equivalence *) Definition equiv_cmd (c1 c2 : cmd) := forall s s', c1 >> s ==> s' <-> c2 >> s ==> s'. Notation "A ~~ B" := (equiv_cmd A B) (at level 75, no associativity). Lemma lem_sim_refl : forall c, c ~~ c. Proof. sauto. Qed. Lemma lem_sim_sym : forall c c', c ~~ c' -> c' ~~ c. Proof. sauto unfold: equiv_cmd. Qed. Lemma lem_sim_trans : forall c1 c2 c3, c1 ~~ c2 -> c2 ~~ c3 -> c1 ~~ c3. Proof. sauto unfold: equiv_cmd. Qed. Lemma lem_seq_assoc : forall c1 c2 c3, c1;; (c2;; c3) ~~ (c1;; c2);; c3. Proof. time sauto unfold: equiv_cmd. Undo. time sauto lazy: on unfold: equiv_cmd. (* "lazy: on" turns off all eager heuristics *) (* This may sometimes speed up "sauto" noticeably, but sometimes it may prevent "sauto" from solving the goal. *) (* To increase the performance of "sauto" you may need to fiddle with various options. *) (* Things to try which commonly result in speed increase (if "sauto" can still solve the goal): - "lazy: on" ("l: on") - "quick: on" ("q: on") - a combination of various options which typically make "sauto" faster but weaker; this is more conservative than "qauto" which additionally severely decreases the proof cost limit - "lq: on" - an abbreviation for "l: on q: on" - "erew: off" - turn off eager rewriting - "rew: off" - turn off rewriting entirely - "ered: off" - turn off eager reduction with "simpl" - "red: off" - turn off reduction entirely - "ecases: off" - turn off eager case splitting - "cases: -" - turn off case splitting entirely - "einv: off sinv: off" - turn off eager inversion heuristics *) Qed. Lemma lem_triv_if : forall b c, If b Then c Else c ~~ c. Proof. unfold equiv_cmd. intros b c s s'. destruct (bval s b) eqn:?; sauto. Qed. Lemma lem_commute_if : forall b1 b2 c1 c2 c3, If b1 Then (If b2 Then c1 Else c2) Else c3 ~~ If b2 Then (If b1 Then c1 Else c3) Else (If b1 Then c2 Else c3). Proof. unfold equiv_cmd. intros *. time (destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto). Undo. time (destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto inv: BigStep ctrs: BigStep). Undo. time (destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto quick: on inv: BigStep ctrs: BigStep). (* "quick: on" sets various options in a way which typically makes "sauto" weaker but faster. "quato" is "hauto" with "quick: on", a smaller cost limit and a different leaf solver. See https://github.com/lukaszcz/coqhammer#Sauto for details. *) Undo. time (destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto lazy: on inv: BigStep ctrs: BigStep). Undo. time (destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto lazy: on quick: on inv: BigStep ctrs: BigStep). Undo. time (destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto lq: on inv: BigStep ctrs: BigStep). (* "lq: on" is an abbreviation for "lazy: on quick: on" *) (* "lazy:" may be abbreviated to "l:" *) (* "quick:" may be abbreviated to "q:" *) Qed. Lemma lem_unfold_while : forall b c, While b Do c ~~ If b Then c;; While b Do c Else Nop. Proof. time sauto unfold: equiv_cmd. Undo. time sauto q: on unfold: equiv_cmd. (* "quick: on" does not result in significant speed increase this time *) Undo. time sauto l: on unfold: equiv_cmd. (* "lazy: on" does *) Qed. Lemma lem_while_cong_aux : forall b c c' s s', While b Do c >> s ==> s' -> c ~~ c' -> While b Do c' >> s ==> s'. Proof. intros *. remember (While b Do c). induction 1; sauto lq: on unfold: equiv_cmd. Qed. Lemma lem_while_cong : forall b c c', c ~~ c' -> While b Do c ~~ While b Do c'. Proof. hauto use: lem_while_cong_aux unfold: equiv_cmd. Qed. (* Small-step operational semantics *) Inductive SmallStep : cmd * state -> cmd * state -> Prop := | AssignSemS : forall x a s, SmallStep (x <- a, s) (Nop, s[x := a]) | SeqSemS1 : forall c s, SmallStep (Nop ;; c, s) (c, s) | SeqSemS2 : forall c1 c2 s c1' s', SmallStep (c1, s) (c1', s') -> SmallStep (c1 ;; c2, s) (c1';; c2, s') | IfTrueS : forall b c1 c2 s, bval s b -> SmallStep (If b Then c1 Else c2, s) (c1, s) | IfFalseS : forall b c1 c2 s, negb (bval s b) -> SmallStep (If b Then c1 Else c2, s) (c2, s) | WhileS : forall b c s, SmallStep (While b Do c, s) (If b Then c;; While b Do c Else Nop, s). Notation "A --> B" := (SmallStep A B) (at level 80, no associativity). Require Import Relations. Definition SmallStepStar := clos_refl_trans (cmd * state) SmallStep. Notation "A -->* B" := (SmallStepStar A B) (at level 80, no associativity). Lemma lem_small_step_deterministic : forall p p1, p --> p1 -> forall p2, p --> p2 -> p1 = p2. Proof. induction 1; sauto lq: on brefl: on. Qed. (* Equivalence between big-step and small-step operational semantics *) Lemma lem_star_seq2 : forall c1 c2 s c1' s', (c1, s) -->* (c1', s') -> (c1;; c2, s) -->* (c1';; c2, s'). Proof. enough (forall p1 p2, p1 -->* p2 -> forall c1 c2 s c1' s', p1 = (c1, s) -> p2 = (c1', s') -> (c1;; c2, s) -->* (c1';; c2, s')). { eauto. } induction 1; sauto lq: on. Qed. Lemma lem_seq_comp : forall c1 c2 s1 s2 s3, (c1, s1) -->* (Nop, s2) -> (c2, s2) -->* (Nop, s3) -> (c1;; c2, s1) -->* (Nop, s3). Proof. intros c1 c2 s1 s2 s3 H1 H2. assert ((c1;; c2, s1) -->* (Nop;; c2, s2)) by sauto use: lem_star_seq2. sauto. Qed. Lemma lem_big_to_small : forall c s s', c >> s ==> s' -> (c, s) -->* (Nop, s'). Proof. intros c s s' H. induction H as [ | | | | | | b c s1 s2 ]. - sauto. - sauto. - sauto use: lem_seq_comp. - sauto. - sauto. - sauto. - assert ((While b Do c, s1) -->* (c;; While b Do c, s1)) by sauto. assert ((c;; While b Do c, s1) -->* (Nop;; While b Do c, s2)) by sauto use: lem_star_seq2. sauto. Qed. Lemma lem_small_to_big_aux : forall p p', p --> p' -> forall c1 s1 c2 s2 s, p = (c1, s1) -> p' = (c2, s2) -> c2 >> s2 ==> s -> c1 >> s1 ==> s. Proof. time (induction 1; sauto). Undo. time (induction 1; sauto l: on). Undo. time (induction 1; sauto lq: on). Qed. Lemma lem_small_to_big_aux_2 : forall p p', p -->* p' -> forall c1 s1 c2 s2 s, p = (c1, s1) -> p' = (c2, s2) -> c2 >> s2 ==> s -> c1 >> s1 ==> s. Proof. induction 1; sauto use: lem_small_to_big_aux. Qed. Lemma lem_small_to_big : forall c s s', (c, s) -->* (Nop, s') -> c >> s ==> s'. Proof. enough (forall p p', p -->* p' -> forall c s s', p = (c, s) -> p' = (Nop, s') -> c >> s ==> s') by eauto. time (induction 1; sauto use: lem_small_to_big_aux_2). Undo. time (induction 1; sauto l: on use: lem_small_to_big_aux_2). (* "l: on" slightly improves performance *) (* Undo. induction 1; sauto q: on use: lem_small_to_big_aux_2. *) (* But "q: on" prevents "sauto" from solving the goal. *) Qed. Corollary cor_big_iff_small : forall c s s', c >> s ==> s' <-> (c, s) -->* (Nop, s'). Proof. sauto use: lem_small_to_big, lem_big_to_small. Qed. (* Hoare triples *) Definition assn := state -> Prop. Definition HoareValid (P : assn) (c : cmd) (Q : assn): Prop := forall s s', c >> s ==> s' -> P s -> Q s'. Notation "|= {{ P }} c {{ Q }}" := (HoareValid P c Q). (* Hoare logic *) Definition entails (P Q : assn) : Prop := forall s, P s -> Q s. Inductive Hoare : assn -> cmd -> assn -> Prop := | Hoare_Nop : forall P, Hoare P Nop P | Hoare_Assign : forall P a x, Hoare (fun s => P s[x := a]) (x <- a) P | Hoare_Seq : forall P Q R c1 c2, Hoare P c1 Q -> Hoare Q c2 R -> Hoare P (c1 ;; c2) R | Hoare_If : forall P Q b c1 c2, Hoare (fun s => P s /\ bval s b) c1 Q -> Hoare (fun s => P s /\ negb (bval s b)) c2 Q -> Hoare P (If b Then c1 Else c2) Q | Hoare_While : forall P b c, Hoare (fun s => P s /\ bval s b) c P -> Hoare P (While b Do c) (fun s => P s /\ negb (bval s b)) | Hoare_conseq: forall P P' Q Q' c, Hoare P c Q -> entails P' P -> entails Q Q' -> Hoare P' c Q'. Notation "|- {{ s | P }} c {{ s' | Q }}" := (Hoare (fun s => P) c (fun s' => Q)). Notation "|- {{ s | P }} c {{ Q }}" := (Hoare (fun s => P) c Q). Notation "|- {{ P }} c {{ s' | Q }}" := (Hoare P c (fun s' => Q)). Notation "|- {{ P }} c {{ Q }}" := (Hoare P c Q). Lemma lem_hoare_strengthen_pre : forall P P' Q c, entails P' P -> |- {{P}} c {{Q}} -> |- {{P'}} c {{Q}}. Proof. sauto unfold: entails. Qed. Lemma lem_hoare_weaken_post : forall P Q Q' c, entails Q Q' -> |- {{P}} c {{Q}} -> |- {{P}} c {{Q'}}. Proof. sauto unfold: entails. Qed. Lemma hoare_assign : forall (P Q : assn) x a, (forall s, P s -> Q s[x := a]) -> |- {{P}} x <- a {{Q}}. Proof. sauto use: lem_hoare_strengthen_pre unfold: entails. Qed. Lemma hoare_while : forall b (P Q: assn) c, |- {{s | P s /\ bval s b}} c {{P}} -> (forall s, P s /\ negb (bval s b) -> Q s) -> |- {{P}} (While b Do c) {{Q}}. Proof. sauto use: lem_hoare_weaken_post unfold: entails. Qed. (* Soundness of Hoare logic *) Theorem thm_hoare_correct : forall P Q c, |- {{P}} c {{Q}} -> |= {{P}} c {{Q}}. Proof. unfold HoareValid. induction 1. - sauto. - sauto. - sauto inv: BigStep. - sauto inv: BigStep. - intros *. remember (While b Do c). induction 1; qauto inv: BigStep. - sauto unfold: entails. Qed. coqhammer-1.3.2-8.20/examples/tutorial/sauto/isort.v000066400000000000000000000110631471571225200222300ustar00rootroot00000000000000(******************************************************************) (* Insertion sort *) From Hammer Require Import Tactics. (* CoqHammer tactics v1.3 or later *) (* Installation: opam repo add coq-released https://coq.inria.fr/opam/released opam install coq-hammer-tactics *) (* Alternatively, download the latest release form https://github.com/lukaszcz/coqhammer, and after unpacking run `make tactics` and `make install-tactics` *) (* Documentation is available at: https://github.com/lukaszcz/coqhammer. *) Require List. Import List.ListNotations. Open Scope list_scope. Require Import Arith. Require Import Lia. Inductive Sorted : list nat -> Prop := | Sorted_0 : Sorted [] | Sorted_1 : forall x, Sorted [x] | Sorted_2 : forall x y l, Sorted (y :: l) -> x <= y -> Sorted (x :: y :: l). (* insert a number into a sorted list preserving the sortedness *) Fixpoint insert (l : list nat) (x : nat) : list nat := match l with | [] => [x] | h :: t => if x <=? h then x :: l else h :: insert t x end. (* insertion sort *) Fixpoint isort (l : list nat) : list nat := match l with | [] => [] | h :: t => insert (isort t) h end. Lemma lem_insert_sorted_hlp : forall l y z, y <= z -> Sorted (y :: l) -> Sorted (y :: insert l z). Proof. intro l. induction l as [|a l IH]. - intros; simpl; auto using Sorted. - intros x y H1 H2. simpl. destruct (Nat.leb_spec y a) as [H|H]. + repeat constructor; auto. inversion H2; auto. + inversion_clear H2. auto using Sorted with arith. Qed. Lemma lem_insert_sorted_hlp' : forall l y z, y <= z -> Sorted (y :: l) -> Sorted (y :: insert l z). Proof. (* "sauto" will *never* try "induction" - one needs to first invoke "induction" manually *) time (induction l; sauto db: arith). (* "db: db1, .., dbn" instructs "sauto" to use the given hint or rewriting databases *) Undo. time (induction l; sauto db: arith inv: Sorted ctrs: Sorted). (* "inv: ind1, .., indn" instructs "sauto" to try inversion (case reasoning) only on elements of the given inductive types *) (* "ctrs: ind1, .., indn" instructs "sauto" to try using constructors of only the given inductive types *) (* "-" stands for an empty list, "*" for a list of all possible inductive types *) (* By default "sauto" tries inversion on elements of and uses constructors of all possible inductive types *) (* I.e. the defaults are: "inv: *" and "ctrs: *" *) Qed. Lemma lem_insert_sorted (l : list nat) (x : nat) : Sorted l -> Sorted (insert l x). Proof. destruct l as [|y l]. - simpl; auto using Sorted. - intro H. simpl. destruct (Nat.leb_spec x y); auto using Sorted, lem_insert_sorted_hlp with arith. Qed. Lemma lem_insert_sorted' (l : list nat) (x : nat) : Sorted l -> Sorted (insert l x). Proof. (* sauto use: lem_insert_sorted_hlp db: arith. *) (* "use: lem1, .., lemn" adds the given lemmas to the context *) (* The default is "use: -" *) (* "sauto" above does not find a proof in reasonable time *) (* Sometimes it is enough to help "sauto" just by providing a few initial steps (particularly when the first step is "destruct" or "inversion") *) time (destruct l; sauto use: lem_insert_sorted_hlp db: arith). Undo. time (destruct l; sauto use: lem_insert_sorted_hlp inv: - ctrs: Sorted db: arith). (* Providing the "inv:" and "ctrs:" options with only the necessary inductive types often noticeably decreases the running time *) (* There is a shorthand for this common use case: "hauto" is "sauto inv: - ctrs: -" *) Qed. Lemma lem_isort_sorted : forall l, Sorted (isort l). Proof. induction l; simpl; auto using Sorted, lem_insert_sorted. Qed. Lemma lem_isort_sorted' : forall l, Sorted (isort l). Proof. induction l; sauto use: lem_insert_sorted. Qed. (* We have proven that the result of "isort" is a sorted list. Now we prove that the result is a permutation of the argument. *) Require Import Sorting.Permutation. Lemma lem_insert_perm : forall l x, Permutation (insert l x) (x :: l). Proof. induction l as [|y ? ?]. - eauto using Permutation. - intro x. simpl. destruct (Nat.leb_spec x y) as [H|H]; eauto using Permutation. Qed. Lemma lem_insert_perm' : forall l x, Permutation (insert l x) (x :: l). Proof. induction l; sauto. Qed. Lemma lem_isort_perm : forall l, Permutation (isort l) l. Proof. induction l; simpl; eauto using Permutation, lem_insert_perm. Qed. Lemma lem_isort_perm' : forall l, Permutation (isort l) l. Proof. induction l; sauto use: lem_insert_perm. Qed. coqhammer-1.3.2-8.20/examples/tutorial/sauto/isortb.v000066400000000000000000000104461471571225200223760ustar00rootroot00000000000000(******************************************************************) (* Insertion sort (boolean version) *) From Hammer Require Import Tactics. From Hammer Require Import Reflect. (* The Reflect module declares "is_true" as a coercion and defines some tactics related to boolean reflection. *) Require List. Import List.ListNotations. Open Scope list_scope. Require Import Arith. Require Import Lia. Require Import Bool. Inductive Sorted : list nat -> Prop := | Sorted_0 : Sorted [] | Sorted_1 : forall x, Sorted [x] | Sorted_2 : forall x y l, Sorted (y :: l) -> x <= y -> Sorted (x :: y :: l). Fixpoint sortedb (l : list nat) : bool := match l with | [] => true | [x] => true | x :: (y :: l') as t => (x <=? y) && sortedb t end. Lemma lem_sortedb_iff_sorted : forall l, sortedb l <-> Sorted l. Proof. induction l; sauto brefl: on. (* The "brefl: on" option enables boolean reflection - automatic conversion of boolean statements (arguments to the "is_true" coercion) into corresponding propositions in Prop. *) Qed. Lemma lem_sortedb_to_sorted_step_by_step : forall l, sortedb l -> Sorted l. Proof. induction l as [| x l IH]. - sauto. - (* sauto. *) simpl. case_split; try strivial. (* "case_split" eliminates one discriminee of a match expression occurring in the goal or in a hypothesis *) breflect. (* "breflect" performs boolean reflection - it implements the "brefl:" option *) (* sauto. *) (* By default "sauto" eagerly eliminates discriminees of all match expressions. This behaviour is controlled by the "ecases:" option. *) (* simpl. case_splitting. *) (* "case_splitting" repeatedly runs "case_split", "subst" and "simpl" - it implements the "cases:" and "ecases:" options *) sauto ecases: off. Undo. sauto cases: -. (* One case specify the inductive types whose elements should be eliminated when they appear as a discriminee of a match expression *) Undo. sauto brefl: on. (* Setting "brefl: on" implies "ecases: off" because eager case splitting is often detrimental in combination with boolean reflection. *) (* Undo. sauto brefl!: on. *) (* Setting "brefl!: on" enables boolean reflection only without affecting other options. *) (* Some options by default affect other options. A primitive version "opt!:" of an option "opt:" never affects any other options. *) Qed. (* insert a number into a sorted list preserving the sortedness *) Fixpoint insert (l : list nat) (x : nat) : list nat := match l with | [] => [x] | h :: t => if x <=? h then x :: l else h :: insert t x end. (* insertion sort *) Fixpoint isort (l : list nat) : list nat := match l with | [] => [] | h :: t => insert (isort t) h end. Lemma lem_insert_sorted_hlp : forall l y z, y <= z -> sortedb (y :: l) -> sortedb (y :: insert l z). Proof. time (induction l; sauto brefl: on db: arith). Undo. (* We do not need inversions in this proof: set "inv: -" or use "hauto" *) time (induction l; sauto brefl: on inv: - ctrs: - db: arith). Qed. Lemma lem_insert_sorted : forall l x, sortedb l -> sortedb (insert l x). Proof. destruct l; hauto brefl: on use: lem_insert_sorted_hlp db: arith. (* "hauto" is "sauto inv: - ctrs: -" *) Qed. Lemma lem_isort_sorted : forall l, sortedb (isort l). Proof. induction l; sauto use: lem_insert_sorted. Qed. Hint Rewrite -> lem_sortedb_iff_sorted : brefl. (* Boolean reflection can be customised by adding rewrite hints to the "brefl" database. *) Lemma lem_insert_sorted_hlp' : forall l y z, y <= z -> sortedb (y :: l) -> sortedb (y :: insert l z). Proof. breflect. induction l; sauto db: arith. Restart. (* induction l; sauto brefl: on db: arith. *) (* Eager case splitting is usually a good idea for non-boolean goals involving inductive types *) induction l; sauto brefl!: on db: arith. (* "brefl!:" enables boolean reflection without affecting "ecases:" *) Qed. Lemma lem_insert_sorted' : forall l x, sortedb l -> sortedb (insert l x). Proof. destruct l; hauto brefl!: on use: lem_insert_sorted_hlp db: arith ctrs: Sorted. Qed. Lemma lem_isort_sorted' : forall l, sortedb (isort l). Proof. induction l; sauto use: lem_insert_sorted. Qed. coqhammer-1.3.2-8.20/examples/tutorial/sauto/itrev.v000066400000000000000000000073631471571225200222310ustar00rootroot00000000000000(* Tail-recursive reverse *) From Hammer Require Import Tactics. From Hammer Require Import Hints. (* The Hints module provides the following rewrite hint databases: shints, slist, sbool, sarith, szarith. *) Require List. Import List.ListNotations. Open Scope list_scope. Fixpoint itrev {A} (l acc : list A) := match l with | [] => acc | h :: t => itrev t (h :: acc) end. Definition rev {A} (l : list A) := itrev l []. Lemma lem_itrev {A} : forall l acc : list A, itrev l acc = itrev l [] ++ acc. Proof. induction l as [| h t IH]. - auto. - intro acc. simpl. rewrite IH. pattern (itrev t [h]). rewrite IH. rewrite <- List.app_assoc. reflexivity. Qed. Lemma lem_itrev' {A} : forall l acc : list A, itrev l acc = itrev l [] ++ acc. Proof. (* induction l; sauto db: slist. *) induction l; ssimpl. (* Simplification tactics in the order of increasing strength and decreasing speed: "simp_hyps", "sintuition", "qsimpl", "ssimpl". *) (* The simplification tactics may change the context in an unpredictable manner and introduce automatically generated hypothesis names. *) rewrite IHl. (* rewrite IHl. *) pattern (itrev l [a]). rewrite IHl. sauto db: slist. (* The "slist" database contains "List.app_assoc" *) (* "sauto" is currently not very good at rewriting - it just tries to apply the "rewrite" tactic *) Restart. induction l as [|x l ?]; simpl. - sauto. - assert (itrev l [x] = itrev l [] ++ [x]) by sauto. sauto db: slist. Qed. Lemma lem_rev_app {A} : forall l1 l2 : list A, rev (l1 ++ l2) = rev l2 ++ rev l1. Proof. unfold rev. induction l1 as [| x l1 IH]; intro l2. - simpl. rewrite List.app_nil_r. reflexivity. - simpl. rewrite lem_itrev. rewrite IH. rewrite <- List.app_assoc. rewrite (lem_itrev l1 [x]). reflexivity. Qed. Lemma lem_rev_app' {A} : forall l1 l2 : list A, rev (l1 ++ l2) = rev l2 ++ rev l1. Proof. induction l1; sauto use: @lem_itrev db: slist unfold: rev. Qed. Lemma lem_rev_rev {A} : forall l : list A, rev (rev l) = l. Proof. unfold rev. induction l as [| x l IH]. - reflexivity. - simpl. rewrite (lem_itrev l [x]). generalize (lem_rev_app (itrev l []) [x]). unfold rev. intro H. rewrite H. rewrite IH. reflexivity. Qed. Lemma lem_rev_rev' {A} : forall l : list A, rev (rev l) = l. Proof. (* induction l; sauto use: @lem_itrev, @lem_rev_app unfold: rev. *) (* induction l; sauto limit: 2000 use: @lem_itrev, @lem_rev_app unfold: rev. *) induction l as [|x l ?]. - reflexivity. - sauto use: (lem_itrev l [x]), (lem_rev_app (itrev l []) [x]) unfold: rev. Qed. Lemma lem_rev_lst {A} : forall l : list A, rev l = List.rev l. Proof. unfold rev. induction l as [|x l IH]. - reflexivity. - simpl. rewrite lem_itrev. rewrite IH. reflexivity. Qed. Lemma lem_rev_lst' {A} : forall l : list A, rev l = List.rev l. Proof. induction l; sauto use: @lem_itrev unfold: rev. Qed. Require Import Sorting.Permutation. Lemma lem_itrev_perm {A} : forall l l' : list A, Permutation (itrev l l') (l ++ l'). Proof. induction l as [| x l IH]; simpl. - eauto using Permutation. - intro l'. enough (Permutation (l ++ (x :: l')) (x :: l ++ l')). { eauto using Permutation. } eauto using Permutation_middle, Permutation_sym. Qed. Lemma lem_itrev_perm' {A} : forall l l' : list A, Permutation (itrev l l') (l ++ l'). Proof. induction l; sauto use: Permutation_middle, Permutation_sym. Qed. Lemma lem_rev_perm {A} : forall l : list A, Permutation (rev l) l. Proof. unfold rev. intro l. rewrite List.app_nil_end. apply lem_itrev_perm. Qed. Lemma lem_rev_perm' {A} : forall l : list A, Permutation (rev l) l. Proof. sauto use: @lem_itrev_perm db: slist unfold: rev. Qed. coqhammer-1.3.2-8.20/examples/tutorial/sauto/msort.v000066400000000000000000000171011471571225200222330ustar00rootroot00000000000000From Hammer Require Import Tactics. From Hammer Require Import Reflect. Require List. Open Scope list_scope. Import List.ListNotations. Require Import Arith. Require Import Lia. Require Import Sorting.Permutation. Require Import Program. Class DecTotalOrder (A : Type) := { leb : A -> A -> bool; leb_total_dec : forall x y, {leb x y}+{leb y x}; leb_antisym : forall x y, leb x y -> leb y x -> x = y; leb_trans : forall x y z, leb x y -> leb y z -> leb x z }. Arguments leb {A _}. Arguments leb_total_dec {A _}. Arguments leb_antisym {A _}. Arguments leb_trans {A _}. Instance dto_nat : DecTotalOrder nat. Proof. apply Build_DecTotalOrder with (leb := Nat.leb); induction x; sauto. Defined. Inductive Sorted {A} {dto : DecTotalOrder A} : list A -> Prop := | Sorted_0 : Sorted [] | Sorted_1 : forall x, Sorted [x] | Sorted_2 : forall x y l, Sorted (y :: l) -> leb x y -> Sorted (x :: y :: l). Lemma lem_sorted_tail {A} {dto : DecTotalOrder A} : forall l x, Sorted (x :: l) -> Sorted l. Proof. sauto. Qed. (* "LeLst x l" holds if "x" is smaller or equal to all elements in "l" *) Definition LeLst {A} {dto : DecTotalOrder A} (x : A) := List.Forall (leb x). Lemma lem_lelst_trans {A} {dto : DecTotalOrder A} : forall l x y, LeLst y l -> leb x y -> LeLst x l. Proof. induction 1; sauto. Qed. Lemma lem_lelst_sorted {A} {dto : DecTotalOrder A} : forall l x, Sorted (x :: l) <-> LeLst x l /\ Sorted l. Proof. time (induction l; sauto). Undo. induction l; sintuition. Undo. (* simplification tactics: sintuition, qsimpl, ssimpl *) induction l; qsimpl. Undo. (* From "Sorted (a :: l)" it follows that "LeLst a l" by "H2". *) (* Because "leb x l", "LeLst x (a :: l)" follows from "LeLst a l" by lemma "lem_lelst_trans" *) time (induction l; sauto use: lem_lelst_trans). Undo. (* induction l; sauto use: lem_lelst_trans inv: Sorted, List.Forall. *) (* induction l; sauto use: lem_lelst_trans inv: Sorted. *) (* induction l; sauto use: lem_lelst_trans inv: List.Forall. *) (* induction l; sauto use: lem_lelst_trans inv: Sorted, List.Forall ctrs: -. *) time (induction l; sauto use: lem_lelst_trans inv: Sorted, List.Forall ctrs: Sorted). Undo. time (induction l; sauto lazy: on use: lem_lelst_trans inv: Sorted, List.Forall ctrs: Sorted). (* "lazy: on" turns off all eager heuristics. This may improve performance, but may also make "sauto" fail to solve the goal *) Qed. Lemma lem_lelst_perm_rev {A} {dto : DecTotalOrder A} : forall l1 l2 x, Permutation l1 l2 -> LeLst x l2 -> LeLst x l1. Proof. induction 1; sauto. Qed. Lemma lem_lelst_app {A} {dto : DecTotalOrder A} : forall l1 l2 x, LeLst x l1 -> LeLst x l2 -> LeLst x (l1 ++ l2). Proof. induction 1; sauto. Qed. Hint Resolve lem_lelst_trans lem_lelst_perm_rev lem_lelst_app : lelst. Lemma lem_sorted_concat_1 {A} {dto : DecTotalOrder A} : forall (l l1 l2 : list A) x y, Permutation l (l1 ++ y :: l2) -> Sorted (x :: l1) -> leb x y -> Sorted (y :: l2) -> Sorted l -> Sorted (x :: l). Proof. intros. rewrite lem_lelst_sorted in *. (* sauto db: lelst inv: -. *) split. simp_hyps. eapply lem_lelst_perm_rev; [eassumption|]. apply lem_lelst_app; [assumption|]. constructor; [assumption|]. Check lem_lelst_trans. eauto using lem_lelst_trans. eapply lem_lelst_trans; eassumption. (* Here, "sauto" needs to apply a constructor of "List.Forall", which works on a goal with head "LeLst", but then creates a goal with head "List.Forall" which does not resolve with the "lem_lelst_trans" lemma according to how "eauto" performs resolution *) Restart. intros. rewrite lem_lelst_sorted in *. sauto use: lem_lelst_trans, lem_lelst_perm_rev, lem_lelst_app inv: -. (* "use:" adds the given lemmas to the context, while for lemmas from a hint database only actions associated with the hints are performed in exactly the same way as by "eauto" *) Qed. Lemma lem_lelst_nil {A} {dto : DecTotalOrder A} : forall x, LeLst x []. Proof. sauto. Qed. Lemma lem_lelst_cons {A} {dto : DecTotalOrder A} : forall x y l, LeLst x l -> leb x y -> LeLst x (y :: l). Proof. sauto. Qed. Hint Resolve lem_lelst_nil lem_lelst_cons : lelst. Lemma lem_sorted_concat_2 {A} {dto : DecTotalOrder A} : forall (l l1 l2 : list A) x y, Permutation l (x :: l1 ++ l2) -> Sorted (x :: l1) -> leb y x -> Sorted (y :: l2) -> Sorted l -> Sorted (y :: l). Proof. intros. rewrite lem_lelst_sorted in *. sauto db: lelst inv: -. Qed. Program Fixpoint merge {A} {dto : DecTotalOrder A} (l1 l2 : {l | Sorted l}) {measure (List.length l1 + List.length l2)} : {l | Sorted l /\ Permutation l (l1 ++ l2)} := match l1 with | [] => l2 | h1 :: t1 => match l2 with | [] => l1 | h2 :: t2 => if leb_total_dec h1 h2 then h1 :: merge t1 l2 else h2 :: merge l1 t2 end end. Next Obligation. sauto db: list. Qed. Next Obligation. eauto using lem_sorted_tail. Qed. Next Obligation. sauto use: lem_sorted_concat_1. (* What happened here? *) Undo. simpl_sigma. (* Heuristic simplifications for sigma types are performed by default (controlled by the "sig:" option) *) sauto use: lem_sorted_concat_1. Qed. Next Obligation. eauto using lem_sorted_tail. Qed. Next Obligation. simpl; lia. Qed. Next Obligation. split. - sauto use: lem_sorted_concat_2. - (* sauto use: List.app_comm_cons, Permutation_cons_app. *) simpl_sigma. rewrite List.app_comm_cons. apply Permutation_cons_app. intuition. (* at this point "sauto" would of course also solve the goal *) Qed. Program Fixpoint split {A} (l : list A) {measure (length l)} : { (l1, l2) : list A * list A | length l1 + length l2 = length l /\ length l1 <= length l2 + 1 /\ length l2 <= length l1 + 1 /\ Permutation l (l1 ++ l2) } := match l with | [] => ([], []) | [x] => ([x], []) | x :: y :: t => match split t with | (l1, l2) => (x :: l1, y :: l2) end end. Solve Obligations with sauto use: Permutation_cons_app. Compute ` (split [1; 2; 3; 4; 5; 6; 7; 8; 9]). Lemma lem_split {A} : forall l : list A, 2 <= List.length l -> forall l1 l2, (l1, l2) = ` (split l) -> List.length l1 < List.length l /\ List.length l2 < List.length l. Proof. sauto. Qed. Ltac use_lem_split := match goal with | [ H: (?l1, ?l2) = ` (split ?l) |- _ ] => let Hl := fresh "H" in assert (Hl: 2 <= length l); [ destruct l as [|? [| ? ?]]; simpl | generalize (lem_split l Hl l1 l2) ]; hauto end. Obligation Tactic := idtac. Program Fixpoint mergesort {A} {dto : DecTotalOrder A} (l : list A) {measure (List.length l)} : {l' | Sorted l' /\ Permutation l' l} := match l with | [] => [] | [x] => [x] | _ => match split l with | (l1, l2) => merge (mergesort l1) (mergesort l2) end end. Next Obligation. sauto. Qed. Next Obligation. sauto. Qed. Next Obligation. (* sauto. *) program_simpl. (* sauto use: @lem_split. *) use_lem_split. Qed. Next Obligation. sauto. Qed. Next Obligation. program_simpl; use_lem_split. Qed. Next Obligation. sauto. Qed. Next Obligation. (* simpl. *) split. - sauto. - (* simpl_sigma. *) time hauto use: Permutation_app, Permutation_sym, perm_trans. (* "hauto" is just "sauto inv: - ctrs: -" *) Undo. time qauto use: Permutation_app, Permutation_sym, perm_trans. (* "qauto" is "sauto" with various options which make it much weaker but typically much faster *) Qed. Next Obligation. sauto. Qed. Next Obligation. program_simpl. Defined. Compute ` (mergesort [2; 7; 3; 1; 4; 6; 5; 8; 0; 8]). coqhammer-1.3.2-8.20/examples/tutorial/sauto/order.v000066400000000000000000000046461471571225200222140ustar00rootroot00000000000000From Hammer Require Import Tactics Reflect. Require List. Open Scope list_scope. Import List.ListNotations. Class DecTotalOrder (A : Type) := { leb : A -> A -> bool; leb_total_dec : forall x y, {leb x y}+{leb y x}; leb_antisym : forall x y, leb x y -> leb y x -> x = y; leb_trans : forall x y z, leb x y -> leb y z -> leb x z }. Arguments leb {A _}. Arguments leb_total_dec {A _}. Arguments leb_antisym {A _}. Arguments leb_trans {A _}. Definition eq_dec {A} {dto : DecTotalOrder A} : forall x y : A, {x = y}+{x <> y}. intros x y. sdestruct (leb x y). (* The "sdestruct" tactic from the Tactics module destructs boolean terms in the "right" way *) (* "sauto" tries to invert/destruct only the hypotheses - it will not normally try to eliminate composite terms unless they occur as discriminees in match expressions *) - sdestruct (leb y x). + auto using leb_antisym. + (* firstorder. *) (* easy. *) (* eauto. *) (* right. intro. subst. contradiction. *) sauto. (* This is a simple proof, but standard Coq automation tactics can't find it because it requires a combination of proof search with equality reasoning. *) - sdestruct (leb y x). + sauto. + destruct (leb_total_dec x y); auto. Defined. (* "sauto" searches for proofs in intuitionistic logic, which can equivalently be seen as program synthesis. "eq_dec" is a certified computable function which decides whether the equality holds or not. *) Require Import Recdef. (* for Function *) Function lexb {A} {dto : DecTotalOrder A} (l1 l2 : list A) : bool := match l1 with | [] => true | x :: l1' => match l2 with | [] => false | y :: l2' => if eq_dec x y then lexb l1' l2' else leb x y end end. Instance dto_list {A} {dto_a : DecTotalOrder A} : DecTotalOrder (list A). Proof. apply Build_DecTotalOrder with (leb := lexb). - induction x; sauto. - intros x y. functional induction (lexb x y). + (* sauto. *) sauto inv: list. + sauto. + sauto. + (* sauto. *) (* ssimpl inv: -. *) sauto inv: - use: leb_antisym. - intros x y. functional induction (lexb x y); sauto. Defined. Instance dto_nat : DecTotalOrder nat. Proof. apply Build_DecTotalOrder with (leb := Nat.leb); induction x; sauto. Defined. Compute leb [1; 2; 3] [1; 4; 5; 6]. Compute leb [1; 2; 3] [1]. Compute leb 2 3. Compute leb 3 2. coqhammer-1.3.2-8.20/src/000077500000000000000000000000001471571225200146535ustar00rootroot00000000000000coqhammer-1.3.2-8.20/src/htimeout/000077500000000000000000000000001471571225200165115ustar00rootroot00000000000000coqhammer-1.3.2-8.20/src/htimeout/htimeout.c000066400000000000000000000044451471571225200205220ustar00rootroot00000000000000/*++ * NAME * htimeout * SUMMARY * run command with bounded time * SYNOPSIS * htimeout [-signal] time command ... * DESCRIPTION * htimeout executes a command and imposes an elapsed time limit. * The command is run in a separate POSIX process group so that the * right thing happens with commands that spawn child processes. * * Arguments: * -signal * Specify an optional signal to send to the controlled process. * By default, htimeout sends SIGKILL, which cannot be caught * or ignored. * time * The elapsed time limit after which the command is terminated. * command * The command to be executed. * DIAGNOSTICS * The command exit status is the exit status of the command * (status 1 in case of a usage error). * AUTHOR(S) * Wietse Venema, modified by Lukasz Czajka * This program is part of SATAN. *--*/ /* System libraries. */ #include #include #include #include #include #include /* Application-specific. */ #define perrorexit(s) { perror(s); exit(1); } static void usage(const char* progname) { fprintf(stderr, "usage: %s [-signal] time command...\n", progname); exit(1); } static void terminate(int sig) { signal(SIGKILL, SIG_DFL); kill(0, SIGKILL); } int main(int argc, char *argv[]) { int time_to_run = 0; pid_t pid; pid_t child_pid; int status; if (argc < 3 || (time_to_run = atoi(argv[1])) <= 0) usage(argv[0]); /* * Run the command and its watchdog in a separate process group so that * both can be killed off with one signal. */ setsid(); switch (child_pid = fork()) { case -1: /* error */ perrorexit("timeout: fork"); case 00: /* run controlled command */ execvp(argv[2], argv + 2); perrorexit(argv[2]); default: /* become watchdog */ (void) signal(SIGHUP, terminate); (void) signal(SIGINT, terminate); (void) signal(SIGQUIT, terminate); (void) signal(SIGTERM, terminate); (void) signal(SIGALRM, terminate); alarm(time_to_run); while ((pid = wait(&status)) != -1 && pid != child_pid) /* void */ ; if (pid == child_pid && WIFEXITED(status)) { return WEXITSTATUS(status); } else { return 1; } } return 0; } coqhammer-1.3.2-8.20/src/lib/000077500000000000000000000000001471571225200154215ustar00rootroot00000000000000coqhammer-1.3.2-8.20/src/lib/dune000066400000000000000000000002501471571225200162740ustar00rootroot00000000000000(library (name hammer_lib) (public_name coq-hammer-tactics.lib) (synopsis "CoqHammer library") (libraries coq-core.plugins.ltac)) (coq.pp (modules g_hammer_lib)) coqhammer-1.3.2-8.20/src/lib/g_hammer_lib.mlg000066400000000000000000000044301471571225200205300ustar00rootroot00000000000000DECLARE PLUGIN "coq-hammer-tactics.lib" { open Ltac_plugin open Extraargs module Utils = Hhutils module Lpo = Hhlpo } TACTIC EXTEND Hammer_isAtom | [ "isAtom" lconstr(t) ] -> { Proofview.Goal.enter begin fun gl -> if Utils.is_atom (Proofview.Goal.sigma gl) t then Tacticals.tclIDTAC else Tacticals.tclFAIL Pp.(str "not an atom") end } END TACTIC EXTEND Hammer_isIndAtom | [ "isIndAtom" lconstr(t) ] -> { Proofview.Goal.enter begin fun gl -> if Utils.is_ind_atom (Proofview.Goal.sigma gl) t then Tacticals.tclIDTAC else Tacticals.tclFAIL Pp.(str "not an inductive atom") end } END TACTIC EXTEND Hammer_isIndexedInd | [ "isIndexedInd" lconstr(t) ] -> { Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in let (head, _) = Utils.destruct_app evd t in let open Constr in let open EConstr in match kind evd head with | Ind(ind, _) -> if Utils.is_indexed_ind ind then Tacticals.tclIDTAC else Tacticals.tclFAIL Pp.(str "not an indexed inductive type") | _ -> Tacticals.tclFAIL Pp.(str "not an indexed inductive type") end } END TACTIC EXTEND Hammer_checkLPO | [ "checkLPO" lconstr(t1) lconstr(t2) ] -> { Proofview.Goal.enter begin fun gl -> if Lpo.lpo (Proofview.Goal.sigma gl) t1 t2 then Tacticals.tclIDTAC else Tacticals.tclFAIL Pp.(str "not LPO decreasing") end } END TACTIC EXTEND Hammer_checkTargetLPO | [ "checkTargetLPO" lconstr(t) ] -> { Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in let (_, _, args) = Utils.destruct_prod evd t in let args = Array.to_list args in match Hhlib.drop (List.length args - 2) args with | [t1; t2] when Lpo.lpo evd t1 t2 -> Tacticals.tclIDTAC | _ -> Tacticals.tclFAIL Pp.(str "not LPO decreasing") end } END TACTIC EXTEND Hammer_checkTargetRevLPO | [ "checkTargetRevLPO" lconstr(t) ] -> { Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in let (_, _, args) = Utils.destruct_prod evd t in let args = Array.to_list args in match Hhlib.drop (List.length args - 2) args with | [t1; t2] when Lpo.lpo evd t2 t1 -> Tacticals.tclIDTAC | _ -> Tacticals.tclFAIL Pp.(str "not LPO decreasing") end } END coqhammer-1.3.2-8.20/src/lib/hammer_errors.ml000066400000000000000000000026571471571225200206320ustar00rootroot00000000000000exception HammerError of string exception HammerFailure of string exception HammerTacticError of string let msg_error s = Feedback.msg_notice (Pp.str s) let catch_errors (f : unit -> 'a) (g : exn -> 'a) = try f () with | Sys.Break -> raise Sys.Break | e -> g e let try_bind_fun (x : 'a) (f : 'a -> 'b) (g : Pp.t -> 'b) = try f x with | HammerError(msg) -> g (Pp.str @@ "Hammer error: " ^ msg) | HammerFailure(msg) -> g (Pp.str @@ "Hammer failed: " ^ msg) | HammerTacticError(msg) -> g (Pp.str msg) | Failure s -> g (Pp.str @@ "CoqHammer bug: please report: " ^ s) | Sys.Break -> raise Sys.Break | CErrors.UserError p -> g p | e -> g (Pp.str @@ "CoqHammer bug: please report: " ^ Printexc.to_string e) let try_fun f g = try_bind_fun () f g let try_cmd (f : unit -> unit) = try_fun f (fun p -> Feedback.msg_notice p) let try_bind_tactic (f : 'a -> unit Proofview.tactic) (x : 'a) : unit Proofview.tactic = try_bind_fun x f (fun p -> Tacticals.tclZEROMSG p) let try_tactic (f : unit -> unit Proofview.tactic) : unit Proofview.tactic = try_fun f (fun p -> Tacticals.tclZEROMSG p) let try_goal_tactic f = Proofview.Goal.enter begin fun gl -> try_tactic (fun () -> f gl) end let try_goal_tactic_nofail f = Proofview.Goal.enter begin fun gl -> try_fun (fun () -> f gl) (fun p -> Feedback.msg_notice p; Proofview.tclUNIT ()) end coqhammer-1.3.2-8.20/src/lib/hammer_lib.mlpack000066400000000000000000000000701471571225200207060ustar00rootroot00000000000000Hammer_errors Hhutils Hhlib Hhlpo Hhpartac G_hammer_lib coqhammer-1.3.2-8.20/src/lib/hhlib.ml000066400000000000000000000057601471571225200170510ustar00rootroot00000000000000module StringSet = Set.Make(String) let comp f g x = f (g x) let flip f x y = f y x let strset_from_lst lst = List.fold_left (fun a x -> StringSet.add x a) StringSet.empty lst let mk_pairs lst = let rec hlp lst acc = match lst with | h :: t -> hlp t (List.fold_left (fun a x -> (h, x) :: a) acc t) | [] -> acc in hlp lst [] let mk_all_pairs lst1 lst2 = List.fold_left (fun a x -> List.fold_left (fun a y -> (x, y) :: a) a lst2) [] lst1 (* numbers from m up to but not including n *) let range m n = let rec go acc i j = if i >= j then acc else go (i :: acc) (i+1) j in List.rev (go [] m n) let rec zip xs ys = match xs with | [] -> [] | x::vs -> match ys with | [] -> [] | y::ws -> (x,y)::(zip vs ws) let unique cmp lst = let rec pom prev lst = match lst with | [] -> [] | h :: t -> if cmp prev h = 0 then pom prev t else h :: pom h t in match lst with | [] -> [] | h :: t -> h :: pom h t let sort_uniq cmp lst = unique cmp (List.sort cmp lst) let rec take n lst = if n = 0 then [] else match lst with | [] -> [] | h :: t -> h :: take (n - 1) t let rec drop n lst = if n = 0 then lst else match lst with | [] -> [] | h :: t -> drop (n - 1) t let rec rev_combine lst1 lst2 acc = match lst1, lst2 with | h1 :: t1, h2 :: t2 -> rev_combine t1 t2 ((h1, h2) :: acc) | [], [] -> acc | _ -> raise (Invalid_argument "rev_combine") let index x = let rec ind n l = match l with [] -> failwith "index" | (h::t) -> if Stdlib.compare x h = 0 then n else ind (n + 1) t in ind 0;; let assoc_index x = let rec ind n l = match l with [] -> failwith "assoc_index" | ((y,_)::t) -> if Stdlib.compare x y = 0 then n else ind (n + 1) t in ind 0;; let massoc x lst = try Some (List.assoc x lst) with Not_found -> None let string_contains s1 s2 = let re = Str.regexp_string s2 in try ignore (Str.search_forward re s1 0); true with Not_found -> false let string_begins_with s1 s2 = try String.sub s1 0 (String.length s2) = s2 with _ -> false let drop_prefix s pref = if string_begins_with s pref then let plen = String.length pref in String.sub s plen (String.length s - plen) else s let rec oiter out f sep = function [] -> () | [e] -> f e | h :: t -> f h; out sep; oiter out f sep t let rec sfold f sep = function [] -> "" | [e] -> f e | h :: t -> f h ^ sep ^ sfold f sep t module type Memo = sig type key val memoize : (key -> 'a) -> key -> 'a end module MakeMemo (H : Hashtbl.HashedType) : Memo with type key = H.t = struct module Htbl = Hashtbl.Make(H) type key = H.t let memoize (f : key -> 'a) = let cache = Htbl.create 128 in begin fun x -> try Htbl.find cache x with Not_found -> begin let y = f x in Htbl.add cache x y; y end end end coqhammer-1.3.2-8.20/src/lib/hhlpo.ml000066400000000000000000000044031471571225200170660ustar00rootroot00000000000000(* Lexicographic path order on terms -- implementation *) open Environ module Utils = Hhutils let gt cgt evd = let env = Global.env () in let rec gt t1 t2 = let open Constr in let open EConstr in let ge t1 t2 = eq_constr evd t1 t2 || gt t1 t2 in let (h1, args1) = Utils.destruct_app evd t1 in let (h2, args2) = Utils.destruct_app evd t2 in match kind evd h1, kind evd h2 with | Const (c1, _), Const(c2, _) when QConstant.equal env c1 c2 -> let rec go args1 args2 = match args1, args2 with | a1 :: args1', a2 :: args2' when eq_constr evd a1 a2 -> go args1' args2' | a1 :: args1', a2 :: args2' when gt a1 a2 -> List.for_all (gt t1) args2' | _ -> false in go (Array.to_list args1) (Array.to_list args2) | Const (c1, _), Const(c2, _) when cgt c1 c2 -> Array.for_all (gt t1) args2 | Const(c1, _), Construct _ | Const(c1, _), Ind _ -> Array.for_all (gt t1) args2 | _ -> Array.exists (fun x -> ge x t2) args1 in gt let lpo_cache = Hashtbl.create 128 let rec const_gt c1 c2 = try Hashtbl.find lpo_cache (c1, c2) with Not_found -> begin let b = if Declareops.is_opaque (Global.lookup_constant c1) then false else match Global.body_of_constant Library.indirect_accessor c1 with | Some (b, _, _) -> let env = Global.env () in let consts = Utils.fold_constr_ker begin fun _ acc t -> let open Constr in match kind t with | Const(c, _) when not (QConstant.equal env c c1) -> c :: acc | _ -> acc end [] b in let rec go lst = match lst with | c :: lst' -> if QConstant.equal env c c2 || const_gt c c2 then true else go lst' | [] -> false in go consts | None -> false in Hashtbl.add lpo_cache (c1, c2) b; b end let lpo = gt const_gt let clear_cache () = Hashtbl.clear lpo_cache coqhammer-1.3.2-8.20/src/lib/hhlpo.mli000066400000000000000000000004361471571225200172410ustar00rootroot00000000000000(* Lexicographic path order on terms *) open Names val gt : (Constant.t -> Constant.t -> bool) -> Evd.evar_map -> EConstr.t -> EConstr.t -> bool val const_gt : Constant.t -> Constant.t -> bool val lpo : Evd.evar_map -> EConstr.t -> EConstr.t -> bool val clear_cache : unit -> unit coqhammer-1.3.2-8.20/src/lib/hhpartac.ml000066400000000000000000000035001471571225200175430ustar00rootroot00000000000000(* Parallel invocation of tactics *) let partac time lst0 cont = let rec pom lst pids = match lst with | [] -> let pid2 = Unix.fork () in if pid2 = 0 then begin (* the watchdog *) if time > 0 then begin Unix.sleep time; List.iter (fun i -> try Unix.kill i Sys.sigterm with _ -> ()) pids end; exit 0 end else let clean () = List.iter (fun i -> try Unix.kill i Sys.sigterm with _ -> ()) pids; ignore (try Unix.kill pid2 Sys.sigterm with _ -> ()); List.iter (fun i -> try ignore (Unix.waitpid [] i) with _ -> ()) pids in let n = List.length lst0 in let rec wait k = if k = 0 then begin clean (); cont (-1) (Proofview.tclZERO Logic_monad.Tac_Timeout) end else let (pid, status) = Unix.wait () in if pid = pid2 && time > 0 then begin clean (); cont (-1) (Proofview.tclZERO Logic_monad.Tac_Timeout) end else if List.mem pid pids then match status with | Unix.WEXITED 0 -> begin clean (); let i = n - Hhlib.index pid pids - 1 in cont i (List.nth lst0 i) end | _ -> wait (k - 1) else wait k in wait n | tac :: t -> let pid = Unix.fork () in if pid = 0 then begin (* a worker *) Proofview.tclOR (Proofview.tclBIND tac (fun _ -> exit 0)) (fun _ -> exit 1) end else pom t (pid :: pids) in pom lst0 [] coqhammer-1.3.2-8.20/src/lib/hhutils.ml000066400000000000000000000510361471571225200174400ustar00rootroot00000000000000open Util open Names open Ltac_plugin let intern_constr env evd cexpr = Constrintern.interp_constr_evars env evd cexpr let tacinterp tac = Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac let to_constr r = match r with | Names.GlobRef.VarRef(v) -> EConstr.mkVar v | Names.GlobRef.ConstRef(c) -> EConstr.mkConst c | Names.GlobRef.IndRef(i) -> EConstr.mkInd i | Names.GlobRef.ConstructRef(cr) -> EConstr.mkConstruct cr let get_global_from_id id = Nametab.locate (Libnames.qualid_of_ident id) let get_global s = Nametab.locate (Libnames.qualid_of_string s) let exists_global s = try ignore (get_global s); true with Not_found -> false let match_globref m g = let (p2, id2) = Libnames.repr_path (Nametab.path_of_global g) in let l1 = List.rev @@ Names.DirPath.repr (Nametab.dirpath_of_module m) and l2 = List.rev @@ id2 :: Names.DirPath.repr p2 in let rec pom l1 l2 = match l1, l2 with | [], _ -> true | id1 :: t1, id2 :: t2 -> Id.equal id1 id2 && pom t1 t2 | _ -> false in pom l1 l2 let get_constr s = to_constr (get_global s) let get_inductive s = match get_global s with | Names.GlobRef.IndRef(i) -> i | _ -> failwith "not an inductive type" let get_inductive_from_id id = match get_global_from_id id with | Names.GlobRef.IndRef(i) -> i | _ -> failwith "not an inductive type" let get_inductive_from_qualid q = match Nametab.locate q with | Names.GlobRef.IndRef(i) -> i | _ -> failwith "not an inductive type" let get_const s = match get_global s with | Names.GlobRef.ConstRef(c) -> c | _ -> failwith "not a constant" let get_const_from_id id = match get_global_from_id id with | Names.GlobRef.ConstRef(c) -> c | _ -> failwith "not a constant" let get_const_from_qualid q = match Nametab.locate q with | Names.GlobRef.ConstRef(c) -> c | _ -> failwith "not a constant" let get_ind_name ind = Libnames.string_of_path (Nametab.path_of_global (Globnames.canonical_gr (Names.GlobRef.IndRef ind))) let get_ind_nparams ind = let mind = fst (Inductive.lookup_mind_specif (Global.env ()) ind) in let open Declarations in mind.mind_nparams let get_ind_constrs ind = let mind = fst (Inductive.lookup_mind_specif (Global.env ()) ind) in let open Declarations in Array.to_list mind.mind_packets.(snd ind).mind_user_lc let get_ind_nconstrs ind = let mind = fst (Inductive.lookup_mind_specif (Global.env ()) ind) in let open Declarations in Array.length mind.mind_packets.(snd ind).mind_user_lc let get_ind_nargs ind = let mind = fst (Inductive.lookup_mind_specif (Global.env ()) ind) in let open Declarations in mind.mind_nparams + mind.mind_packets.(snd ind).mind_nrealargs let is_indexed_ind ind = let mind = fst (Inductive.lookup_mind_specif (Global.env ()) ind) in let open Declarations in mind.mind_packets.(snd ind).mind_nrealargs > 0 (***************************************************************************************) let rec close f ctx t = match ctx with | [] -> t | (x,ty) :: l -> f (x, ty, close f l t) (***************************************************************************************) let get_tactic (s : string) = try (Tacenv.locate_tactic (Libnames.qualid_of_string s)) with Not_found -> failwith ("tactic not found: " ^ s) let get_tacexpr tac args = CAst.make (Tacexpr.TacArg Tacexpr.(TacCall(CAst.make (Locus.ArgArg(None, get_tactic tac), args)))) let ltac_apply tac (args:Tacexpr.glob_tactic_arg list) = Tacinterp.eval_tactic (get_tacexpr tac args) let ltac_eval tac (args: Tacinterp.Value.t list) = let fold arg (i, vars, lfun) = let id = Id.of_string ("x" ^ string_of_int i) in let x = Tacexpr.Reference (Locus.ArgVar CAst.(make id)) in (succ i, x :: vars, Id.Map.add id arg lfun) in let (_, args, lfun) = List.fold_right fold args (0, [], Id.Map.empty) in let ist = { (Tacinterp.default_ist ()) with Tacinterp.lfun = lfun; } in Tacinterp.eval_tactic_ist ist (get_tacexpr tac args) let get_hyps gl = List.map (function | Context.Named.Declaration.LocalAssum(x, y) -> (Context.(x.binder_name), y) | Context.Named.Declaration.LocalDef(x, _, y) -> (Context.(x.binder_name), y)) (Proofview.Goal.hyps gl) (***************************************************************************************) let rec drop_lambdas evd n t = let open Constr in let open EConstr in if n = 0 then t else match kind evd t with | Lambda (na, ty, body) -> drop_lambdas evd (n - 1) body | _ -> t let rec take_lambdas evd n t = let open Constr in let open EConstr in if n = 0 then [] else match kind evd t with | Lambda (na, ty, body) -> (na, ty) :: take_lambdas evd (n - 1) body | _ -> [] let rec drop_prods evd n t = let open Constr in let open EConstr in if n = 0 then t else match kind evd t with | Prod (na, ty, body) -> drop_prods evd (n - 1) body | _ -> t let rec take_prods evd n t = let open Constr in let open EConstr in if n = 0 then [] else match kind evd t with | Prod (na, ty, body) -> (na, ty) :: take_prods evd (n - 1) body | _ -> [] let rec drop_all_lambdas evd t = let open Constr in let open EConstr in match kind evd t with | Lambda (na, ty, body) -> drop_all_lambdas evd body | _ -> t let rec take_all_lambdas evd t = let open Constr in let open EConstr in match kind evd t with | Lambda (na, ty, body) -> (na, ty) :: take_all_lambdas evd body | _ -> [] let rec drop_all_prods evd t = let open Constr in let open EConstr in match kind evd t with | Prod (na, ty, body) -> drop_all_prods evd body | _ -> t let rec take_all_prods evd t = let open Constr in let open EConstr in match kind evd t with | Prod (na, ty, body) -> (na, ty) :: take_all_prods evd body | _ -> [] let destruct_app = EConstr.decompose_app let destruct_prod evd t = let prods = take_all_prods evd t and (h, args) = destruct_app evd (drop_all_prods evd t) in (prods, h, args) let destruct_app_red evd t = let open Constr in let open EConstr in let head0 = match kind evd t with | App (h, _) -> h | _ -> t in match kind evd head0 with | Const _ -> let (head, args) = match Tacred.red_product (Global.env ()) evd t with | Some t -> destruct_app evd t | None -> destruct_app evd t in (head0, head, args) | _ -> let (head, args) = destruct_app evd t in (head0, head, args) let destruct_prod_red evd t = let t = Termops.strip_outer_cast evd t in let prods = take_all_prods evd t and (h0, h, args) = destruct_app_red evd (drop_all_prods evd t) in (prods, h0, h, args) (***************************************************************************************) let map_fold_constr f acc evd t = let open Constr in let open EConstr in let rec hlp m acc t = let fold_arr k ac ar = let (ac1, lst) = Array.fold_left (fun (ac,l) x -> let (ac',x') = hlp k ac x in (ac',x'::l)) (ac, []) ar in (ac1, Array.of_list (List.rev lst)) in let fold_list k ac lst = let (ac, ar) = fold_arr k ac (Array.of_list lst) in (ac, Array.to_list ar) in let fold_ctx k ac (nas, c) = let (ac, c') = hlp (k + Array.length nas) ac c in (ac, (nas, c')) in match kind evd t with | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> f m acc t | Cast (ty1,ck,ty2) -> let (acc1, ty1') = hlp m acc ty1 in let (acc2, ty2') = hlp m acc1 ty2 in f m acc2 (mkCast(ty1',ck,ty2')) | Prod (na,ty,c) -> let (acc1, ty') = hlp m acc ty in let (acc2, c') = hlp (m+1) acc1 c in f m acc2 (mkProd(na,ty',c')) | Lambda (na,ty,c) -> let (acc1, ty') = hlp m acc ty in let (acc2, c') = hlp (m+1) acc1 c in f m acc2 (mkLambda(na,ty',c')) | LetIn (na,b,ty,c) -> let (acc1, ty') = hlp m acc ty in let (acc2, b') = hlp m acc1 b in let (acc3, c') = hlp (m+1) acc2 c in f m acc3 (mkLetIn(na,b',ty',c')) | App (a,args) -> let (acc1, a') = hlp m acc a in let (acc2, args') = fold_arr m acc1 args in f m acc2 (mkApp(a',args')) | Proj (p,r,c) -> let (acc1, c') = hlp m acc c in f m acc1 (mkProj(p,r,c')) | Evar ((evk, _) as ev) -> let cl = Evd.expand_existential evd ev in let (acc1, cl') = fold_list m acc cl in f m acc1 (mkLEvar evd (evk,cl')) | Case (ci,u,pms,(p,r),iv,c,bl) -> let (acc, pms') = fold_arr m acc pms in let (acc, p') = fold_ctx m acc p in let (acc, iv') = Constr.fold_map_invert (hlp m) acc iv in let (acc, c') = hlp m acc c in let (acc, bl') = CArray.fold_left_map (fun acc c -> fold_ctx m acc c) acc bl in f m acc (mkCase(ci,u,pms',(p',r),iv',c',bl')) | Fix (nvn,recdef) -> let (fnames,typs,bodies) = recdef in let (acc1, typs') = fold_arr m acc typs in let (acc2, bodies') = fold_arr (m + Array.length typs) acc1 bodies in f m acc2 (mkFix(nvn,(fnames,typs',bodies'))) | CoFix (n,recdef) -> let (fnames,typs,bodies) = recdef in let (acc1, typs') = fold_arr m acc typs in let (acc2, bodies') = fold_arr (m + Array.length typs) acc1 bodies in f m acc2 (mkCoFix(n,(fnames,typs',bodies'))) | Array (u,arr,b,ty) -> let (acc1, arr') = fold_arr m acc arr in let (acc2, b') = hlp m acc1 b in let (acc3, ty') = hlp m acc2 ty in f m acc3 (mkArray(u,arr',b',ty')) in hlp 0 acc t let map_constr f evd x = snd (map_fold_constr (fun m () t -> ((), f m t)) () evd x) let fold_constr f acc evd t = let open Constr in let open EConstr in let rec hlp m acc t = let fold_arr k ac ar = Array.fold_left (hlp k) ac ar in let fold_list k ac ar = List.fold_left (hlp k) ac ar in let fold_ctx k ac (nas, c) = hlp (k + Array.length nas) ac c in match kind evd t with | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> f m acc t | Cast (ty1,ck,ty2) -> let acc1 = hlp m acc ty1 in let acc2 = hlp m acc1 ty2 in f m acc2 t | Prod (na,ty,c) -> let acc1 = hlp m acc ty in let acc2 = hlp (m+1) acc1 c in f m acc2 t | Lambda (na,ty,c) -> let acc1 = hlp m acc ty in let acc2 = hlp (m+1) acc1 c in f m acc2 t | LetIn (na,b,ty,c) -> let acc1 = hlp m acc ty in let acc2 = hlp m acc1 b in let acc3 = hlp (m+1) acc2 c in f m acc3 t | App (a,args) -> let acc1 = hlp m acc a in let acc2 = fold_arr m acc1 args in f m acc2 t | Proj (p,_,c) -> let acc1 = hlp m acc c in f m acc1 t | Evar ev -> let cl = Evd.expand_existential evd ev in let acc1 = fold_list m acc cl in f m acc1 t | Case (ci,u,pms,(p,_),iv,c,bl) -> let acc = fold_arr m acc pms in let acc = fold_ctx m acc p in let acc = hlp m acc c in let acc = fold_invert (hlp m) acc iv in let acc = fold_arr m acc (Array.map snd bl) in f m acc t | Fix (nvn,recdef) -> let (fnames,typs,bodies) = recdef in let acc1 = fold_arr m acc typs in let acc2 = fold_arr (m + Array.length typs) acc1 bodies in f m acc2 t | CoFix (n,recdef) -> let (fnames,typs,bodies) = recdef in let acc1 = fold_arr m acc typs in let acc2 = fold_arr (m + Array.length typs) acc1 bodies in f m acc2 t | Array (u,arr,b,ty) -> let acc1 = fold_arr m acc arr in let acc2 = hlp m acc1 b in let acc3 = hlp m acc2 ty in f m acc3 t in hlp 0 acc t let fold_constr_shallow f acc evd t = let open Constr in let open EConstr in let rec hlp acc t = let fold_arr ac ar = Array.fold_left hlp ac ar in let fold_list ac ar = List.fold_left hlp ac ar in let fold_ctx ac (_, c) = hlp ac c in match kind evd t with | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> f acc t | Cast (ty1,ck,ty2) -> let acc1 = hlp acc ty1 in let acc2 = hlp acc1 ty2 in f acc2 t | Prod (na,ty,c) -> let acc1 = hlp acc ty in f acc1 t | Lambda (na,ty,c) -> let acc1 = hlp acc ty in f acc1 t | LetIn (na,b,ty,c) -> let acc1 = hlp acc ty in let acc2 = hlp acc1 b in f acc2 t | App (a,args) -> let acc1 = hlp acc a in let acc2 = fold_arr acc1 args in f acc2 t | Proj (p,_,c) -> let acc1 = hlp acc c in f acc1 t | Evar ev -> let cl = Evd.expand_existential evd ev in let acc1 = fold_list acc cl in f acc1 t | Case (ci,u,pms,(p,_),iv,c,bl) -> let acc = fold_arr acc pms in let acc = fold_ctx acc p in let acc = fold_invert hlp acc iv in let acc = hlp acc c in let acc = fold_arr acc (Array.map snd bl) in f acc t | Fix (nvn,recdef) -> let (fnames,typs,bodies) = recdef in let acc1 = fold_arr acc typs in f acc1 t | CoFix (n,recdef) -> let (fnames,typs,bodies) = recdef in let acc1 = fold_arr acc typs in f acc1 t | Array (u,arr,b,ty) -> let acc1 = fold_arr acc arr in let acc2 = hlp acc1 b in let acc3 = hlp acc2 ty in f acc3 t in hlp acc t let map_fold_constr_ker f acc t = let open Constr in let rec hlp m acc t = let fold_arr k ac ar = let (ac1, lst) = Array.fold_left (fun (ac,l) x -> let (ac',x') = hlp k ac x in (ac',x'::l)) (ac, []) ar in (ac1, Array.of_list (List.rev lst)) in let fold_ctx k ac (nas, c) = let (ac, c') = hlp (k + Array.length nas) ac c in (ac, (nas, c')) in match kind t with | Rel _ | Meta _ | Var _ | Sort _ | Const _ | Ind _ | Construct _ | Int _ | Float _ | String _ -> f m acc t | Cast (ty1,ck,ty2) -> let (acc1, ty1') = hlp m acc ty1 in let (acc2, ty2') = hlp m acc1 ty2 in f m acc2 (mkCast(ty1',ck,ty2')) | Prod (na,ty,c) -> let (acc1, ty') = hlp m acc ty in let (acc2, c') = hlp (m+1) acc1 c in f m acc2 (mkProd(na,ty',c')) | Lambda (na,ty,c) -> let (acc1, ty') = hlp m acc ty in let (acc2, c') = hlp (m+1) acc1 c in f m acc2 (mkLambda(na,ty',c')) | LetIn (na,b,ty,c) -> let (acc1, ty') = hlp m acc ty in let (acc2, b') = hlp m acc1 b in let (acc3, c') = hlp (m+1) acc2 c in f m acc3 (mkLetIn(na,b',ty',c')) | App (a,args) -> let (acc1, a') = hlp m acc a in let (acc2, args') = fold_arr m acc1 args in f m acc2 (mkApp(a',args')) | Proj (p,r,c) -> let (acc1, c') = hlp m acc c in f m acc1 (mkProj(p,r,c')) | Evar _ -> assert false | Case (ci,u,pms,(p,r),iv,c,bl) -> let (acc, pms') = fold_arr m acc pms in let (acc, p') = fold_ctx m acc p in let (acc, iv') = Constr.fold_map_invert (hlp m) acc iv in let (acc, c') = hlp m acc c in let (acc, bl') = CArray.fold_left_map (fun acc c -> fold_ctx m acc c) acc bl in f m acc (mkCase(ci,u,pms',(p',r),iv',c',bl')) | Fix (nvn,recdef) -> let (fnames,typs,bodies) = recdef in let (acc1, typs') = fold_arr m acc typs in let (acc2, bodies') = fold_arr (m + Array.length typs) acc1 bodies in f m acc2 (mkFix(nvn,(fnames,typs',bodies'))) | CoFix (n,recdef) -> let (fnames,typs,bodies) = recdef in let (acc1, typs') = fold_arr m acc typs in let (acc2, bodies') = fold_arr (m + Array.length typs) acc1 bodies in f m acc2 (mkCoFix(n,(fnames,typs',bodies'))) | Array (u,arr,b,ty) -> let (acc1, arr') = fold_arr m acc arr in let (acc2, b') = hlp m acc1 b in let (acc3, ty') = hlp m acc2 ty in f m acc3 (mkArray(u,arr',b',ty')) in hlp 0 acc t let map_constr_ker f x = snd (map_fold_constr_ker (fun m () t -> ((), f m t)) () x) let fold_constr_ker f acc x = fst (map_fold_constr_ker (fun m acc t -> (f m acc t, t)) acc x) let rel_occurs evd t lst = let open Constr in let open EConstr in fold_constr begin fun n b x -> match kind evd x with | Rel j -> if List.mem (j - n) lst then true else b | _ -> b end false evd t let do_shift evd k t = let open Constr in let open EConstr in map_constr begin fun n t -> match kind evd t with | Rel i when i > n -> mkRel (i + k) | _ -> t end evd t let shift_binders_down evd k t = assert (k >= 0); if k = 0 then t else do_shift evd (-k) t let shift_binders_up evd k t = assert (k >= 0); if k = 0 then t else do_shift evd k t let is_False evd t = let open Constr in let open EConstr in match kind evd t with | Ind (ind, _) when get_ind_name ind = "Coq.Init.Logic.False" -> true | _ -> false let rec is_atom evd t = let open Constr in let open EConstr in match kind evd t with | App (h, _) -> is_atom evd h | Ind (ind, _) -> let s = get_ind_name ind in s <> "Coq.Init.Logic.and" && s <> "Coq.Init.Logic.or" && s <> "Coq.Init.Logic.ex" | Const _ | Sort _ | Evar _ | Meta _ | Var _ | Rel _ -> true | Prod (_, h, f) when is_atom evd h && is_False evd f -> true | _ -> false let rec is_ind_atom evd t = let open Constr in let open EConstr in match kind evd t with | App (h, _) -> is_ind_atom evd t | Ind _ -> true | _ -> false let is_product evd t = let open Constr in let open EConstr in match kind evd t with | Prod _ when not (is_atom evd t) -> true | _ -> false let get_app_head evd t = match destruct_app evd t with (h, _) -> h let get_head evd t = match destruct_prod evd t with (_, h, _) -> h let get_app_head_red evd t = match destruct_app_red evd t with (_, h, _) -> h let get_head_red evd t = match destruct_prod_red evd t with (_, _, h, _) -> h let print_constr evd t = Feedback.msg_notice (Printer.pr_constr_env (Global.env ()) evd (EConstr.to_constr evd t)) let constr_to_string evd t = Pp.string_of_ppcmds (Printer.pr_constr_env (Global.env ()) evd (EConstr.to_constr evd t)) let constr_expr_to_string evd e = Pp.string_of_ppcmds (Ppconstr.pr_constr_expr (Global.env ()) evd e) let constant_to_string c = Pp.string_of_ppcmds (Printer.pr_constant (Global.env ()) c) let inductive_to_string ind = Pp.string_of_ppcmds (Printer.pr_inductive (Global.env ()) ind) let globref_to_string g = Pp.string_of_ppcmds (Printer.pr_global g) (******************************************************************************************) (* Code copied from eauto.ml with minor modifications *) let unify_e_resolve flags h = Hints.hint_res_pf ~with_evars:true ~with_classes:true ~flags h let e_exact flags h = let open Proofview.Notations in Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let sigma, c = Hints.fresh_hint env sigma h in Proofview.Unsafe.tclEVARS sigma <*> Eauto.e_give_exact c end let tac_of_hint db h concl = let open Hints in let st = Auto.auto_flags_of_state (Hint_db.transparent_state db) in let tac = function | Res_pf h -> Auto.unify_resolve st h | ERes_pf h -> unify_e_resolve st h | Give_exact h -> e_exact st h | Res_pf_THEN_trivial_fail h -> Tacticals.tclTHEN (unify_e_resolve st h) (Tacticals.tclSOLVE [Eauto.e_assumption; Tactics.reflexivity; Tactics.any_constructor true None]) | Unfold_nth c -> Tactics.reduce (Genredexpr.Unfold [Locus.AllOccurrences,c]) Locusops.onConcl | Extern (p, tacast) -> Auto.conclPattern concl p tacast in FullHint.run h tac (******************************************************************************************) type hint = int * Hints.hint_db * Hints.FullHint.t let hint_priority (p, _, _) = p let hint_tactic (_, db, h) t = tac_of_hint db h t let hint_to_string (_, _, h) = Pp.string_of_ppcmds @@ Hints.FullHint.print (Global.env ()) Evd.empty h let find_hints db secvars env evd t = try let open Hints in let hdc = Hints.decompose_app_bound evd t in let hints = if Termops.occur_existential evd t then match Hint_db.map_eauto env evd ~secvars hdc t db with | ModeMatch (_, l) -> l | ModeMismatch -> [] else Hint_db.map_auto env evd ~secvars hdc t db in List.map (fun h -> (FullHint.priority h, db, h)) hints with Hints.Bound -> [] (******************************************************************************************) coqhammer-1.3.2-8.20/src/lib/hhutils.mli000066400000000000000000000110701471571225200176030ustar00rootroot00000000000000open Names open Ltac_plugin val intern_constr : Environ.env -> Evd.evar_map -> Constrexpr.constr_expr -> Evd.evar_map * EConstr.t val tacinterp : Geninterp.Val.t -> unit Proofview.tactic val exists_global : string -> bool val match_globref : ModPath.t -> GlobRef.t -> bool val get_constr : string -> EConstr.t val get_global : string -> GlobRef.t val get_global_from_id : Id.t -> GlobRef.t val get_inductive : string -> inductive val get_inductive_from_id : Id.t -> inductive val get_inductive_from_qualid : Libnames.qualid -> inductive val get_const : string -> Constant.t val get_const_from_id : Id.t -> Constant.t val get_const_from_qualid : Libnames.qualid -> Constant.t val get_ind_name : inductive -> string val get_ind_nparams : inductive -> int val get_ind_constrs : inductive -> Constr.t list val get_ind_nconstrs : inductive -> int val get_ind_nargs : inductive -> int val is_indexed_ind : inductive -> bool val close : (Name.t * 'a * 'a -> 'a) -> (Name.t * 'a) list -> 'a -> 'a val get_tactic : string -> Tacexpr.ltac_constant val get_tacexpr : string -> Tacexpr.glob_tactic_arg list -> Tacexpr.glob_tactic_expr val ltac_apply : string -> Tacexpr.glob_tactic_arg list -> unit Proofview.tactic val ltac_eval : string -> Tacinterp.Value.t list -> unit Proofview.tactic val get_hyps : Proofview.Goal.t -> (Id.t * EConstr.t) list val drop_lambdas : Evd.evar_map -> int -> EConstr.t -> EConstr.t val take_lambdas : Evd.evar_map -> int -> EConstr.t -> (Name.t EConstr.binder_annot * EConstr.t) list val drop_prods : Evd.evar_map -> int -> EConstr.t -> EConstr.t val take_prods : Evd.evar_map -> int -> EConstr.t -> (Name.t EConstr.binder_annot * EConstr.t) list val drop_all_lambdas : Evd.evar_map -> EConstr.t -> EConstr.t val take_all_lambdas : Evd.evar_map -> EConstr.t -> (Name.t EConstr.binder_annot * EConstr.t) list val drop_all_prods : Evd.evar_map -> EConstr.t -> EConstr.t val take_all_prods : Evd.evar_map -> EConstr.t -> (Name.t EConstr.binder_annot * EConstr.t) list val destruct_app : Evd.evar_map -> EConstr.t -> EConstr.t (* head *) * EConstr.t array (* args *) val destruct_app_red : Evd.evar_map -> EConstr.t -> EConstr.t (* head *) * EConstr.t (* head after red *) * EConstr.t array (* args after red *) val destruct_prod : Evd.evar_map -> EConstr.t -> (Name.t EConstr.binder_annot * EConstr.t) list (* prods *) * EConstr.t (* head *) * EConstr.t array (* args *) val destruct_prod_red : Evd.evar_map -> EConstr.t -> (Name.t EConstr.binder_annot * EConstr.t) list (* prods *) * EConstr.t (* head *) * EConstr.t (* head after red *) * EConstr.t array (* args after red *) val map_fold_constr : (int -> 'a -> EConstr.t -> 'a * EConstr.t) -> 'a -> Evd.evar_map -> EConstr.t -> 'a * EConstr.t val map_constr : (int -> EConstr.t -> EConstr.t) -> Evd.evar_map -> EConstr.t -> EConstr.t val fold_constr : (int -> 'a -> EConstr.t -> 'a) -> 'a -> Evd.evar_map -> EConstr.t -> 'a val fold_constr_shallow : ('a -> EConstr.t -> 'a) -> 'a -> Evd.evar_map -> EConstr.t -> 'a val map_fold_constr_ker : (int -> 'a -> Constr.t -> 'a * Constr.t) -> 'a -> Constr.t -> 'a * Constr.t val map_constr_ker : (int -> Constr.t -> Constr.t) -> Constr.t -> Constr.t val fold_constr_ker : (int -> 'a -> Constr.t -> 'a) -> 'a -> Constr.t -> 'a (* De Bruijn indices in Rel are 1-based *) val rel_occurs : Evd.evar_map -> EConstr.t -> int list -> bool val shift_binders_down : Evd.evar_map -> int -> EConstr.t -> EConstr.t val shift_binders_up : Evd.evar_map -> int -> EConstr.t -> EConstr.t val is_False : Evd.evar_map -> EConstr.t -> bool val is_atom : Evd.evar_map -> EConstr.t -> bool val is_ind_atom : Evd.evar_map -> EConstr.t -> bool val is_product : Evd.evar_map -> EConstr.t -> bool val get_app_head : Evd.evar_map -> EConstr.t -> EConstr.t val get_head : Evd.evar_map -> EConstr.t -> EConstr.t val get_app_head_red : Evd.evar_map -> EConstr.t -> EConstr.t val get_head_red : Evd.evar_map -> EConstr.t -> EConstr.t val print_constr : Evd.evar_map -> EConstr.t -> unit val constr_to_string : Evd.evar_map -> EConstr.t -> string val constr_expr_to_string : Evd.evar_map -> Constrexpr.constr_expr -> string val constant_to_string : Constant.t -> string val inductive_to_string : inductive -> string val globref_to_string : GlobRef.t -> string type hint val hint_priority : hint -> int val hint_tactic : hint -> EConstr.t -> unit Proofview.tactic val hint_to_string : hint -> string val find_hints : Hints.hint_db -> Id.Pred.t -> Environ.env -> Evd.evar_map -> EConstr.t -> hint list coqhammer-1.3.2-8.20/src/plugin/000077500000000000000000000000001471571225200161515ustar00rootroot00000000000000coqhammer-1.3.2-8.20/src/plugin/META.coq-hammer000066400000000000000000000004621471571225200206540ustar00rootroot00000000000000package "plugin" ( description = "Coq Hammer Plugin" requires = "coq-core.plugins.ltac coq-hammer-tactics.lib" archive(byte) = "hammer_plugin.cma" archive(native) = "hammer_plugin.cmxa" plugin(byte) = "hammer_plugin.cma" plugin(native) = "hammer_plugin.cmxs" directory = "." ) directory = "."coqhammer-1.3.2-8.20/src/plugin/coq_convert.ml000066400000000000000000000157741471571225200210430ustar00rootroot00000000000000(* Convert hhterm to coqterm *) open Hh_term open Coqterms open Coq_transl_opts (***************************************************************************************) (* Check input *) let is_valid_name name = not (is_logop name) && (String.length name < 2 || String.sub name 0 2 <> "$_") let check_name name = if not (is_valid_name name) then failwith ("check_name: " ^ name) else () (***************************************************************************************) (* Convert input to coqterms *) let to_coqsort kind = match kind with | Comb(Id "$Sort", Id "$Prop") -> SortProp | Comb(Id "$Sort", Id "$Type") -> SortType | Comb(Id "$Sort", Id "$Set") -> if opt_set_to_type then SortType else SortSet | _ -> SortType (* the last case may happen with e.g.: Let U := Type. Variable A : U. Variable x : A. *) let rec to_coqterm tm = let is_fix = function Comb(Id "$Fix", _) -> true | _ -> false and is_cofix = function Id "$CoFix" -> true | _ -> false in match tm with | Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.True"), _) -> Const("$True") | Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.False"), _) -> Const("$False") | Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.and"), _) -> Const("&") | Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.or"), _) -> Const("|") | Comb(Id "$Const", Id "Coq.Init.Logic.not") -> Const("~") | Comb(Id "$Const", Id "Coq.Init.Logic.iff") -> Const("<=>") | Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.eq"), _) when opt_translate_eq -> Const("=") | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.ex"), _)), Comb(Comb(Id "$ConstrArray", _), Comb(Comb(Comb(Id "$Lambda", Comb(Id "$Name", Id varname)), vartype), body))) -> Quant("?", (varname, to_coqterm vartype, to_coqterm body)) | Comb(Comb(Id "$App", Comb(Id "$Const", Id "Coq.Init.Logic.all")), Comb(Comb(Id "$ConstrArray", _), Comb(Comb(Comb(Id "$Lambda", Comb(Id "$Name", Id varname)), vartype), body))) -> Quant("!", (varname, to_coqterm vartype, to_coqterm body)) | Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.ex"), _)) -> Const("?") | Comb(Id "$Const", Id "Coq.Init.Logic.all") -> Const("!") | Comb(Id "$Rel", Id num) -> Var(num) | Comb(Id "$Const", Id name) -> check_name name; Const(name) | Comb(Id "$Var", Id name) -> check_name name; Const(name) | Comb(Comb(Id "$App", left), args) -> let rec build_app left args = match args with | Comb(args2, arg) -> App(build_app left args2, to_coqterm arg) | Id "$ConstrArray" -> to_coqterm left | _ -> failwith "to_coqterm: build_app" in build_app left args | Comb(Comb(Comb(Id "$Lambda", Comb(Id "$Name", Id varname)), vartype), body) -> check_name varname; Lam(varname, to_coqterm vartype, to_coqterm body) | Comb(Comb(Comb(Comb(Id "$Case", Comb(Comb(Comb(Comb(Id "$CaseInfo", Comb(Comb(Id "$Ind", Id indname), _)), Id npar), ndecls_arr), nargs_arr)), return_type_lam), matched_term), cases) -> let rec parse_cases cases nargs_arr acc = match cases, nargs_arr with | Id "$ConstrArray", Id "$IntArray" -> acc | Comb(cases2, c), Comb(nargs_arr2, Id nargs) -> parse_cases cases2 nargs_arr2 ((int_of_string nargs, to_coqterm c) :: acc) | _ -> failwith "parse_cases" in check_name indname; Case(indname, to_coqterm matched_term, to_coqterm return_type_lam, int_of_string npar, parse_cases cases ndecls_arr []) | Comb(Comb(Comb(Comb(Id "$LetIn", Comb(Id "$Name", Id varname)), value), vartype), body) -> check_name varname; Let(to_coqterm value, (varname, to_coqterm vartype, to_coqterm body)) | Comb(Comb(Id "$Construct", _), Id constrname) -> check_name constrname; Const(constrname) | Comb(Comb(Id "$Cast", trm), ty) -> Cast(to_coqterm trm, to_coqterm ty) | Comb(Comb(fix_or_cofix, Id result_index), Comb(Comb(Comb(Id "$PrecDeclaration", names), types), bodies)) when (is_fix fix_or_cofix || is_cofix fix_or_cofix) -> let rec build_lst f (trm : hhterm) acc = match trm with | Comb(trm2, arg) -> build_lst f trm2 ((f arg) :: acc) | Id "$ConstrArray" | Id "$NameArray" -> acc | _ -> failwith "to_coqterm: build_lst" and name_to_str = function | Comb(Id "$Name", Id name) -> check_name name; name | _ -> failwith "name_to_str" in Fix((if is_fix fix_or_cofix then CoqFix else CoqCoFix), int_of_string result_index, build_lst name_to_str names [], build_lst to_coqterm types [], build_lst to_coqterm bodies []) | Comb(Comb(Comb(Id "$Prod", Comb(Id "$Name", Id varname)), vartype), body) -> check_name varname; Prod(varname, to_coqterm vartype, to_coqterm body) | Comb(Id "$Sort", Id "$Prop") -> SortProp | Comb(Id "$Sort", Id "$Set") -> if opt_set_to_type then SortType else SortSet | Comb(Id "$Sort", Id "$Type") -> SortType | Comb(Comb(Id "$Ind", Id indname), _) -> check_name indname; Const(indname) | Comb(Comb(Comb(Id "$Proj", _), _), _) -> Const("unsupported__" ^ unique_id ()) (* TODO: primitive projections not really supported *) | Comb(Id "$Int", _) -> Const("unsupported__" ^ unique_id ()) (* TODO: primitive integers not really supported *) | Comb(Id "$Float", _) -> Const("unsupported__" ^ unique_id ()) (* TODO: primitive floats not really supported *) | _ -> print_endline (string_of_hhterm tm); failwith ("to_coqterm") let to_coqdef (def : hhdef) (lst : hhdef list) = let rec parse_constrs lst cacc = match lst with | (Comb(Comb(Id "$Construct", _), Id constrname), _, kind, ty, _) :: t -> parse_constrs t (constrname :: cacc) | _ -> List.rev cacc in match def with | (Comb(Comb(Id "$Ind", Id indname), Id params_num), _, kind, ty, _) -> let constrs = parse_constrs lst [] in log 2 ("to_coqdef: " ^ indname); (indname, IndType(indname, constrs, int_of_string params_num), to_coqterm (Lazy.force ty), to_coqsort kind) | (Comb(Id "$Const", Id name), _, Comb(Id "$Sort", Id "$Prop"), ty, _) -> log 2 ("to_coqdef (omit proof): " ^ name); (name, Const(name), to_coqterm (Lazy.force ty), SortProp) | (Comb(Id "$Const", Id name), opaque, kind, ty, prf) -> begin log 2 ("to_coqdef: " ^ name); let prf = if opaque then Const(name) else let vp = Lazy.force prf in match vp with | Id "$Axiom" -> Const(name) | _ -> to_coqterm vp in (name, prf, to_coqterm (Lazy.force ty), to_coqsort kind) end | (Comb(Comb(Id "$Construct", _), Id constrname), _, kind, ty, _) -> log 2 ("to_coqdef: " ^ constrname); (constrname, Const(constrname), to_coqterm (Lazy.force ty), to_coqsort kind) | _ -> failwith ("to_coqdef: " ^ get_hhdef_name def) coqhammer-1.3.2-8.20/src/plugin/coq_convert.mli000066400000000000000000000002131471571225200211720ustar00rootroot00000000000000 open Hh_term open Coqterms (* convert hhterm to coqterm *) val to_coqdef : hhdef (* def *) -> hhdef list (* future def list *) -> coqdef coqhammer-1.3.2-8.20/src/plugin/coq_transl.ml000066400000000000000000001104701471571225200206530ustar00rootroot00000000000000(* Translation from Coq to FOL *) open Hammer_lib open Coqterms open Coq_transl_opts open Hh_term (***************************************************************************************) (* Adjust variable names *) let adjust_varnames = let rename_abs n (vname, ty, body) = (string_of_int n ^ "_" ^ vname, ty, body) in map_coqterm0 begin fun n ctx tm -> match tm with | Var(x) -> let i = int_of_string x - 1 in let nthctx = List.nth ctx i in let vname = fst nthctx in Var(string_of_int (n - 1 - i) ^ "_" ^ vname) | Lam a -> Lam (rename_abs n a) | Prod a -> Prod (rename_abs n a) | Quant(op, a) -> Quant(op, rename_abs n a) | Let(value, a) -> Let(value, rename_abs n a) | Fix(cft, m, names, types, bodies) -> let names2 = List.rev (fst (List.fold_left (fun (acc, k) name -> ((string_of_int k ^ "_" ^ name) :: acc, k + 1)) ([], n) names)) in Fix(cft, m, names2, types, bodies) | _ -> tm end (***************************************************************************************) (* Adjust logical operators *) let adjust_logops = map_coqterm begin fun ctx tm -> match tm with | App(Const(op), Lam a) when op = "!" || op = "?" -> Quant(op, a) | App(App(App(Const("="), ty), x), y) -> Equal(x, y) | _ -> tm end (***************************************************************************************) (* Initialization *) let reinit (lst : hhdef list) = let conv h t = let def = Coq_convert.to_coqdef h t in let def = coqdef_map adjust_varnames def in let def = coqdef_map adjust_logops def in if opt_simpl then coqdef_map simpl def else def in let rec add_defs lst = match lst with | h :: t -> let name = get_hhdef_name h in if not (Defhash.mem name) then Defhash.add_lazy name (lazy (conv h t)); add_defs t | [] -> () in log 1 "Reinitializing..."; let hastype_type = mk_fun_ty (Const("$Any")) (mk_fun_ty SortType SortProp) in begin try List.iter Defhash.add logop_defs; if opt_hastype then Defhash.add ("$HasType", Const("$HasType"), hastype_type, SortType) with _ -> () end; add_defs lst (***************************************************************************************) (* Axioms monad *) (* the second element is a function which given a list of axioms prepends to it a fixed list of axioms (in time proportional to the prepended list) and returns the result *) (* type 'a axioms_monad = 'a * ((string * fol) -> (string * fol)) *) let return tm = (tm, fun axs -> axs) let bind (x, mk1) f = let (y, mk2) = f x in (y, (fun axs -> mk2 (mk1 axs))) let (>>=) = bind let (>>) m1 m2 = bind m1 (fun _ -> m2) let lift f m = m >>= fun x -> return (f x) let listM_nth lst n = let rec pom lst n acc x = match lst with | [] -> return x | h :: t -> if n = 0 then begin acc >> h >>= fun r -> pom t (n - 1) (return r) r end else pom t (n - 1) (acc >> h) x in match lst with | [] -> failwith "listM_nth" | h :: t -> begin h >>= fun r -> pom t n (return r) r end let add_axiom ax = log 3 ("add_axiom: " ^ fst ax); ((), fun axs -> ax :: axs) let extract_axioms m = (snd m) [] (* general axioms for any Coq translation *) let coq_axioms = [ ("_HAMMER_COQ_TRUE", Const("$True")); ("_HAMMER_COQ_FALSE", App(Const("~"), Const("$False"))); ("_HAMMER_COQ_TYPE_TYPE", mk_hastype (Const("Type")) (Const("Type"))) ] @ if opt_set_to_type then [] else [ ("_HAMMER_COQ_SET_TYPE", mk_hastype (Const("Set")) (Const("Type"))); ("_HAMMER_COQ_SET_SUB_TYPE", mk_forall "X" type_any (mk_impl (mk_hastype (Var("X")) (Const("Set"))) (mk_hastype (Var("X")) (Const("Type"))))) ] (***************************************************************************************) (* Coqterms hash *) let coqterm_hash = Hashing.create lift (***************************************************************************************) (* Inversion axioms for inductive types *) let mk_inversion_conjs params_num args targs cacc = let rec mk_conjs ctx args targs cacc = match args, targs with | ((name, ty) :: args2), (y :: targs2) -> let cacc2 = if Coq_typing.check_prop ctx ty then cacc else (mk_eq (Var(name)) y) :: cacc in mk_conjs ((name, ty) :: ctx) args2 targs2 cacc2 | [], [] -> if cacc = [] then Const("$True") else join_right mk_and cacc | _ -> failwith "mk_inversion_conjs" in let args2 = Hhlib.drop params_num args and ctx = List.rev (Hhlib.take params_num args) in mk_conjs ctx args2 targs cacc let rec subst_params lst prms tm = match lst with | [] -> tm | (name, _) :: t -> let tm2 = subst_params t (List.tl prms) tm in if var_occurs name tm2 then substvar name (List.hd prms) tm2 else tm2 let mk_inversion params indname constrs matched_term f = let rec mk_disjs constrs acc = match constrs with | cname :: constrs2 -> let (_, targs, cargs) = Coq_typing.destruct_type_app (coqdef_type (Defhash.find cname)) in let params_num = List.length params in let cargs1 = Hhlib.take params_num cargs in let cargs2 = List.map (fun (name, ty) -> (name, subst_params cargs1 params ty)) (Hhlib.drop params_num cargs) in let targs2 = List.map (fun tm -> subst_params cargs1 params tm) (Hhlib.drop params_num targs) in let eqt = mk_eq matched_term (mk_long_app (Const(cname)) (params @ mk_vars cargs2)) in let disj = mk_long_exists cargs2 (f cname targs2 cargs2 eqt) in mk_disjs constrs2 (disj :: acc) | [] -> List.rev acc in let disjs = mk_disjs constrs [] in match disjs with | [] -> Const("$False") | _ -> join_right mk_or disjs let mk_prop_inversion params indname args constrs = let rec mk_disjs constrs acc = match constrs with | cname :: constrs2 -> let ty = coqdef_type (Defhash.find cname) in let (_, targs, cargs) = Coq_typing.destruct_type_app ty in let params_num = List.length params in let cargs1 = Hhlib.take params_num cargs in let cargs2 = List.map (fun (name, ty) -> (name, subst_params cargs1 params ty)) (Hhlib.drop params_num cargs) in let targs2 = List.map (fun tm -> subst_params cargs1 params tm) (Hhlib.drop params_num targs) in let disj = mk_long_exists cargs2 (mk_inversion_conjs params_num args targs2 []) in mk_disjs constrs2 (disj :: acc) | [] -> List.rev acc in if args = [] then begin if constrs = [] then Const("$False") else Const("$True") end else let disjs = mk_disjs constrs [] in match disjs with | [] -> Const("$False") | _ -> join_right mk_or disjs let rec mk_guards ctx vars tm = match vars with | (name, ty) :: vars2 -> if Coq_typing.check_prop ctx ty then (mk_impl ty (mk_guards ((name, ty) :: ctx) vars2 (subst_proof name ty tm))) else (mk_impl (App(App(Const("$HasType"), Var(name)), ty)) (mk_guards ((name, ty) :: ctx) vars2 tm)) | [] -> tm (* The following mutually recursively defined functions return (coqterm axioms_monad) or (unit axioms_monad). *) let rec add_inversion_axioms0 mkinv indname axname fvars lvars constrs matched_term f = (* Note: the correctness of calling `prop_to_formula' below depends on the implementation of `convert_term' (that it never invokes check_prop on an application of the form App(..App(Const(cname),_)..)) *) let inv = mkinv indname constrs matched_term f in match inv with | Const("$False") -> return () | _ -> let m = if !opt_closure_guards then close (fvars @ lvars) (fun ctx -> prop_to_formula ctx inv) else if opt_lambda_guards then let ctx = List.rev fvars in let mtfvars = get_fvars ctx matched_term in let fvars0 = List.filter (fun (name, _) -> not (List.mem_assoc name mtfvars)) fvars and fvars1 = mtfvars in (close fvars0 (fun ctx1 -> make_guarded_forall ctx1 fvars1 (fun _ -> prop_to_formula ctx (mk_long_forall lvars inv)))) else let vars = fvars @ lvars in let ctx = List.rev vars in let vars1 = get_fvars ctx matched_term in make_fol_forall [] vars (mk_guards [] vars1 inv) in m >>= fun tm -> add_axiom (mk_axiom axname tm) (***************************************************************************************) (* Lambda-lifting, fix-lifting and case-lifting *) and lambda_lifting axname name fvars lvars1 tm = debug 3 (fun () -> print_header "lambda_lifting" tm (fvars @ lvars1)); let rec extract_lambdas tm acc = match tm with | Lam(vname, vtype, body) -> extract_lambdas body ((vname, vtype) :: acc) | _ -> (List.rev acc, tm) in let (lvars2, body2) = extract_lambdas tm [] in let lvars = lvars1 @ lvars2 in match body2 with | Fix(_) -> fix_lifting axname name fvars lvars body2 | Case(_) -> case_lifting axname name fvars lvars body2 | _ -> close fvars begin fun ctx -> let mk_eqv = if Coq_typing.check_prop (List.rev_append lvars ctx) body2 then mk_equiv else mk_eq in let eqv = mk_eqv (mk_long_app (Const(name)) (mk_vars (fvars @ lvars))) body2 in if !opt_closure_guards || opt_lambda_guards then prop_to_formula ctx (mk_long_forall lvars eqv) else make_fol_forall ctx lvars eqv end >>= (fun tm -> add_axiom (mk_axiom axname tm)) >> convert (List.rev fvars) (mk_long_app (Const(name)) (mk_vars fvars)) and fix_lifting axname dname fvars lvars tm = debug 3 (fun () -> print_header "fix_lifting" tm (fvars @ lvars)); match tm with | Fix(cft, k, names, types, bodies) -> let fix_pref = "$_fix_" ^ unique_id () ^ "_" in let names1 = List.map ((^) fix_pref) names in let names2 = if axname = "" then names1 else Hhlib.take k names1 @ [ dname ] @ Hhlib.drop (k + 1) names1 and axnames = if axname = "" then names1 else Hhlib.take k names1 @ [ axname ] @ Hhlib.drop (k + 1) names1 in let vars = mk_vars (fvars @ lvars) in let env = List.map2 (fun name name2 -> (name, mk_long_app (Const(name2)) vars)) names names2 in let prep body = List.fold_left (fun tm (name, value) -> simple_subst name value tm) body env in List.iter2 (fun name2 ty -> let ty2 = mk_long_prod fvars (mk_long_prod lvars ty) in try Defhash.add (mk_def name2 (Const(name2)) ty2 (if Coq_typing.check_prop [] ty2 then SortProp else SortType)) with _ -> ()) names2 types; listM_nth (List.map2 (fun (axname2, name2) body -> lambda_lifting axname2 name2 fvars lvars (prep body)) (List.combine axnames names2) bodies) k | _ -> failwith "fix_lifting" and case_lifting axname0 name0 fvars lvars tm = debug 3 (fun () -> print_header "case_lifting" tm (fvars @ lvars)); let get_params indty rt params_num = let args = Coq_typing.get_type_args indty in let rec pom n tm = match tm with | Lam(_, ty, body) -> if n = 0 then let (_, tyargs) = flatten_app ty in assert (List.length tyargs >= params_num); Hhlib.take params_num tyargs else pom (n - 1) body | _ -> failwith "get_params" in let n = List.length args in assert (n >= params_num); pom (n - params_num) rt in let generic_match () = let name = "$_generic_case_" ^ unique_id () in let def = (name, Const(name), Const("$Any"), SortType) in Defhash.add def; Const(name) in try begin match tm with | Cast(Const("$Proof"), _) | Const("$Proof") -> return (generic_match ()) | Case(indname, matched_term, return_type, params_num, branches) -> let df = try Defhash.find indname with _ -> raise Not_found in begin match df with | (_, IndType(_, constrs, pnum), indty, _) -> assert (pnum = params_num); if Coq_typing.check_type_target_is_prop indty then return (generic_match ()) else let fname = if name0 = "" then "$_case_" ^ indname ^ "$" ^ unique_id () else name0 in let axname = if name0 = "" then fname else axname0 in convert (List.rev fvars) (mk_long_app (Const(fname)) (mk_vars fvars)) >>= fun case_replacement -> let case_repl2 = mk_long_app case_replacement (mk_vars lvars) in let params = get_params indty return_type params_num in let rec hlp constrs branches params params_num vars tm = let rec get_branch cname cstrs brs = match cstrs, brs with | c :: cstrs2, b :: brs2 -> if c = cname then b else get_branch cname cstrs2 brs2 | _ -> failwith "case_lifting: get_branch" in begin fun cname _ args eqt -> let (n, branch) = get_branch cname constrs branches in assert (List.length args <= n); (* We may have List.length args < n if there are some lets in the type and they get evaluated away. We do not properly deal with this (rare) situation: the generated formula will in this case not be correct (the branch (`cr' below) will miss arguments). *) let ctx = List.rev (vars @ args) in let ys = mk_vars args in let cr = simpl (mk_long_app branch ys) in match cr with | Case(indname2, mt2, return_type2, pnum2, branches2) -> let df = try Defhash.find indname2 with _ -> raise Not_found in begin match df with | (_, IndType(_, constrs2, pn), indty2, _) -> assert (pn = pnum2); if Coq_typing.check_type_target_is_prop indty2 then eqt else let params2 = get_params indty2 return_type2 pnum2 in mk_guards [] (get_fvars ctx mt2) (mk_and eqt (mk_inversion params2 indname constrs2 mt2 (hlp constrs2 branches2 params2 pnum2 (vars @ args) cr))) | _ -> failwith "impossible" end | _ -> let eqv = if Coq_typing.check_prop ctx cr then mk_equiv case_repl2 cr else mk_eq case_repl2 cr in mk_and eqt eqv end in add_inversion_axioms0 (mk_inversion params) indname axname fvars lvars constrs matched_term (hlp constrs branches params params_num (fvars @ lvars) tm) >> return case_replacement | _ -> failwith "impossible" end | _ -> failwith "case_lifting" end with Not_found -> log 2 ("case exception: " ^ name0); return (generic_match ()) (*****************************************************************************************) (* Convert definitions to axioms *) (* Invariant: there is no variable covering in `tm'; the variables from ctx are pairwise distinct and they do not occur bound in `tm' *) and convert ctx tm = debug 3 (fun () -> print_header "convert" tm ctx); match tm with | Quant(op, (name, ty, body)) -> assert (ty <> type_any); let mk = if op = "!" then mk_impl else mk_and in if Coq_typing.check_prop ctx ty then (prop_to_formula ctx ty) >>= fun x1 -> (prop_to_formula ctx (subst_proof name ty body)) >>= fun x2 -> return (mk x1 x2) else (make_guard ctx ty (Var(name))) >>= fun x1 -> (prop_to_formula ((name, ty) :: ctx) body) >>= fun x2 -> return (Quant(op, (name, type_any, mk x1 x2))) | Equal(x, y) -> convert_term ctx x >>= fun x1 -> convert_term ctx y >>= fun x2 -> return (Equal(x1, x2)) | App(App(Const(c), x), y) when is_bin_logop c -> prop_to_formula ctx x >>= fun x2 -> prop_to_formula ctx y >>= fun y2 -> assert (x2 <> Const("$Proof")); assert (y2 <> Const("$Proof")); return (App(App(Const(c), x2), y2)) | App(Const("~"), x) -> prop_to_formula ctx x >>= fun x2 -> assert (x2 <> Const("$Proof")); return (App(Const("~"), x2)) | App(App(Const("$HasType"), x), y) -> convert ctx x >>= fun x2 -> make_guard ctx y x2 | App(x, y) -> convert ctx x >>= fun x2 -> if x2 = Const("$Proof") then return (Const("$Proof")) else convert_term ctx y >>= fun y2 -> if y2 = Const("$Proof") then return x2 else return (App(x2, y2)) | Lam(_) -> remove_lambda ctx tm | Case(_) -> remove_case ctx tm | Cast(Const("$Proof"), _) -> return (Const("$Proof")) | Cast(_) -> remove_cast ctx tm | Fix(_) -> remove_fix ctx tm | Let(_) -> remove_let ctx tm | Prod(_) -> if Coq_typing.check_prop ctx tm then prop_to_formula ctx tm else remove_type ctx tm | SortProp -> return (Const("Prop")) | SortSet -> return (Const("Set")) | SortType -> return (Const("Type")) | Var(name) -> if Coq_typing.check_proof_var ctx name then return (Const("$Proof")) else return (Var(name)) | Const(_) -> return tm | IndType(_) -> failwith "convert" and convert_term ctx tm = debug 3 (fun () -> print_header "convert_term" tm ctx); let should_lift = match tm with | Var(_) | Const(_) -> false | App(App(Const(c), _), _) when is_bin_logop c -> true | App(Const("~"), _) -> true | App(_) -> false | _ -> Coq_typing.check_prop ctx tm in if should_lift then let name = "$_prop_" ^ unique_id () in let fvars = get_fvars ctx tm in convert ctx (mk_long_app (Const(name)) (mk_vars fvars)) >>= fun tm2 -> close fvars begin fun ctx -> convert ctx tm >>= fun r -> return (mk_equiv tm2 r) end >>= fun r -> add_axiom (mk_axiom name r) >> return tm2 else convert ctx tm and prop_to_formula ctx tm = debug 3 (fun () -> print_header "prop_to_formula" tm ctx); match tm with | Prod(vname, ty1, ty2) -> if Coq_typing.check_prop ctx ty1 then prop_to_formula ctx ty1 >>= fun tm1 -> prop_to_formula ctx (subst_proof vname ty1 ty2) >>= fun tm2 -> return (mk_impl tm1 tm2) else make_guard ctx ty1 (Var(vname)) >>= fun tm1 -> prop_to_formula ((vname, ty1) :: ctx) ty2 >>= fun tm2 -> return (mk_forall vname type_any (mk_impl tm1 tm2)) | _ -> convert ctx tm (* `x' does not get converted *) and make_guard ctx ty x = debug 3 (fun () -> print_header_nonl "make_guard" ty ctx; print_coqterm x; print_newline ()); match ty with | Prod(_) -> if opt_type_lifting then remove_type ctx ty >>= fun ty1 -> return (mk_hastype x ty1) else (* refresh_bvars is necessary here to correctly translate e.g. Prod(x, Prod(x, ty1, ty2), ty3) *) type_to_guard ctx (refresh_bvars ty) x | _ -> convert ctx ty >>= fun ty1 -> return (mk_hastype x ty1) (* `x' does not get converted *) and type_to_guard ctx ty x = debug 3 (fun () -> print_header_nonl "type_to_guard" ty ctx; print_coqterm x; print_newline ()); match ty with | Prod(vname, ty1, ty2) -> if Coq_typing.check_prop ctx ty1 then prop_to_formula ctx ty1 >>= fun tm1 -> type_to_guard ctx (subst_proof vname ty1 ty2) x >>= fun tm2 -> return (mk_impl tm1 tm2) else make_guard ctx ty1 (Var(vname)) >>= fun tm1 -> type_to_guard ((vname, ty1) :: ctx) ty2 (App(x, (Var(vname)))) >>= fun tm2 -> return (mk_forall vname type_any (mk_impl tm1 tm2)) | _ -> convert ctx ty >>= fun tm -> return (mk_hastype x tm) and make_fol_forall ctx vars tm = let rec hlp ctx vars tm = match vars with | (name, ty) :: vars2 -> if Coq_typing.check_prop ctx ty then hlp ((name, ty) :: ctx) vars2 (subst_proof name ty tm) else hlp ((name, ty) :: ctx) vars2 tm >>= fun r -> return (mk_forall name type_any r) | [] -> prop_to_formula ctx tm in hlp ctx vars tm and make_guarded_forall ctx vars cont = let rec hlp ctx vars = match vars with | (name, ty) :: vars2 -> begin make_guard ctx ty (Var(name)) >>= fun guard -> hlp ((name, ty) :: ctx) vars2 >>= fun r -> return (mk_forall name type_any (mk_impl guard r)) end | [] -> cont ctx in hlp ctx vars and close vars cont = if !opt_closure_guards then make_guarded_forall [] vars cont else let rec hlp ctx vars = match vars with | (name, ty) :: vars2 -> begin hlp ((name, ty) :: ctx) vars2 >>= fun r -> return (mk_forall name type_any r) end | [] -> cont ctx in hlp [] vars and remove_lambda ctx tm = debug 3 (fun () -> print_header "remove_lambda" tm ctx); Hashing.find_or_insert coqterm_hash ctx tm begin fun cctx ctm -> let name = "$_lam_" ^ unique_id () in lambda_lifting name name (ctx_to_vars cctx) [] ctm end and remove_case ctx tm = debug 3 (fun () -> print_header "remove_case" tm ctx); Hashing.find_or_insert coqterm_hash ctx tm begin fun cctx ctm -> case_lifting "" "" (ctx_to_vars cctx) [] ctm end (* TODO: for case lifting cctx should always include the proof variables tm may depend on; otherwise the resulting FOL problem may be inconsistent *) and remove_cast ctx tm = debug 3 (fun () -> print_header "remove_cast" tm ctx); match tm with | Cast(trm, ty) -> let fvars = get_fvars ctx tm and fname = "$_cast_" ^ unique_id () in convert ctx (mk_long_app (Const(fname)) (mk_vars fvars)) >>= fun tm2 -> let ty2 = mk_long_prod fvars ty in let srt = if Coq_typing.check_prop [] ty2 then SortProp else SortType in if srt <> SortProp then begin let def = mk_def fname (mk_long_lam fvars trm) ty2 srt in add_def_eq_axiom def >> return tm2 end else return (Const("$Proof")) | _ -> failwith "remove_cast" and remove_fix ctx tm = debug 3 (fun () -> print_header "remove_fix" tm ctx); Hashing.find_or_insert coqterm_hash ctx tm begin fun cctx ctm -> fix_lifting "" "" (ctx_to_vars cctx) [] ctm end and remove_let ctx tm = debug 3 (fun () -> print_header "remove_let" tm ctx); match tm with | Let(value, (name, ty, body)) -> let name2 = "$_let_" ^ name ^ "_" ^ unique_id () and fvars = get_fvars ctx (App(value, ty)) in let ty2 = mk_long_prod fvars ty and val2 = mk_long_app (Const(name2)) (mk_vars fvars) in let srt = if Coq_typing.check_prop [] ty2 then SortProp else SortType in let def = mk_def name2 (mk_long_lam fvars value) ty2 srt in Defhash.add def; begin if srt <> SortProp then add_def_eq_axiom def else return () end >> convert ctx (simple_subst name val2 body) | _ -> failwith "remove_let" and remove_type ctx ty = debug 3 (fun () -> print_header "remove_type" ty ctx); Hashing.find_or_insert coqterm_hash ctx ty begin fun cctx cty -> let name = "$_type_" ^ unique_id () and vars = ctx_to_vars cctx in add_def_eq_type_axiom name name vars cty >> convert cctx (mk_long_app (Const(name)) (mk_vars vars)) end and add_def_eq_type_axiom axname name fvars ty = debug 2 (fun () -> print_header "add_def_eq_type_axiom" ty fvars); let vname = "var_" ^ unique_id () in close fvars begin fun ctx -> convert ctx (mk_long_app (Const(name)) (mk_vars fvars)) >>= fun tp -> type_to_guard ctx ty (Var(vname)) >>= fun guard -> return (mk_forall vname type_any (mk_equiv (mk_hastype (Var(vname)) tp) guard)) end >>= fun r -> add_axiom (mk_axiom axname r) and add_typing_axiom name ty = debug 2 (fun () -> print_endline ("add_typing_axiom: " ^ name)); if not (is_logop name) && name <> "$True" && name <> "$False" && ty <> type_any then begin if opt_omit_prop_typing_axioms && Coq_typing.check_type_target_is_prop ty then return () else if opt_type_optimization && (Coq_typing.check_type_target_is_type ty || Coq_typing.check_type_target_is_prop ty) then begin let fix_ax ax = let xvar = refresh_varname "X" in let rec hlp tm = match tm with | Quant("!", (vname, _, body)) -> Quant("!", (vname, type_any, hlp body)) | App(App(Const("=>"), x), y) -> App(App(Const("=>"), x), hlp y) | Equal(x, y) -> if opt_hastype then mk_equiv (App(App(Const "$HasType", x), Var(xvar))) (App(App(Const "$HasType", y), Var(xvar))) else mk_equiv (App(x, Var(xvar))) (App(y, Var(xvar))) | _ -> failwith "add_typing_axiom: fix_ax" in mk_forall xvar type_any (hlp ax) in let name2 = "$_type_" ^ name ^ "_" ^ unique_id () and args = Coq_typing.get_type_args ty in (* TODO: fix proof arguments in ax *) let ys = mk_vars args in let ax = mk_long_forall args (mk_eq (mk_long_app (Const(name2)) ys) (mk_long_app (Const(name)) ys)) in make_guard [] ty (Const(name2)) >>= fun guard -> add_axiom (mk_axiom ("$_tydef_" ^ name2) (fix_ax ax)) >> add_axiom (mk_axiom ("$_typeof_" ^ name) guard) end else begin make_guard [] ty (Const(name)) >>= fun guard -> add_axiom (mk_axiom ("$_typeof_" ^ name) guard) end end else return () and add_def_eq_axiom (name, value, ty, srt) = debug 2 (fun () -> print_endline ("add_def_eq_axiom: " ^ name)); let axname = "$_def_" ^ name in match value with | Lam(_) -> lambda_lifting axname name [] [] value >> return () | Fix(_) -> fix_lifting axname name [] [] value >> return () | Const(c) when c = name -> return () | _ -> begin match ty with | SortProp -> begin prop_to_formula [] value >>= fun r -> add_axiom (mk_axiom axname (mk_equiv (Const(name)) r)) end | SortType | SortSet -> add_def_eq_type_axiom axname name [] value | _ -> begin convert [] value >>= fun r -> add_axiom (mk_axiom axname (mk_eq (Const(name)) r)) end end and add_injection_axioms constr = debug 2 (fun () -> print_endline ("add_injection_axioms: " ^ constr)); let ty = coqdef_type (Defhash.find constr) in let rec hlp ty1 ty2 args1 args2 conjs = match ty1, ty2 with | Prod(name1, lty1, value1), Prod(name2, lty2, value2) -> let lname1 = refresh_varname name1 and lname2 = refresh_varname name2 in let lvalue1 = simple_subst name1 (Var(lname1)) value1 and lvalue2 = simple_subst name2 (Var(lname2)) value2 in mk_forall lname1 lty1 (mk_forall lname2 lty2 (hlp lvalue1 lvalue2 (Var(lname1) :: args1) (Var(lname2) :: args2) ((mk_eq (Var(lname1)) (Var(lname2))) :: conjs))) | _ -> mk_impl (mk_eq (mk_long_app (Const(constr)) (List.rev args1)) (mk_long_app (Const(constr)) (List.rev args2))) (join_left mk_and conjs) in let rec hlp2 ctx ty1 ty2 args1 args2 conjs = match ty1, ty2 with | Prod(name1, lty1, value1), Prod(name2, lty2, value2) -> let lname1 = refresh_varname name1 and lname2 = refresh_varname name2 in let lvalue1 = simple_subst name1 (Var(lname1)) value1 and lvalue2 = simple_subst name2 (Var(lname2)) value2 in (hlp2 ((lname1, lty1) :: (lname2, lty2) :: ctx) lvalue1 lvalue2 (Var(lname1) :: args1) (Var(lname2) :: args2) ((mk_eq (Var(lname1)) (Var(lname2))) :: conjs)) >>= fun r -> return (mk_forall lname1 type_any (mk_forall lname2 type_any r)) | _ -> prop_to_formula ctx (mk_impl (mk_eq (mk_long_app (Const(constr)) (List.rev args1)) (mk_long_app (Const(constr)) (List.rev args2))) (join_left mk_and conjs)) in match ty with | Prod(_) -> begin if !opt_closure_guards || opt_injectivity_guards then prop_to_formula [] (hlp ty ty [] [] []) else hlp2 [] ty ty [] [] [] end >>= fun ax -> add_axiom (mk_axiom ("$_inj_" ^ constr) ax) | _ -> return () and add_discrim_axioms constr1 constr2 = debug 2 (fun () -> print_endline ("add_discrim_axioms: " ^ constr1 ^ ", " ^ constr2)); let ty1 = coqdef_type (Defhash.find constr1) and ty2 = coqdef_type (Defhash.find constr2) in let rec hlp ty1 ty2 args1 args2 = match ty1, ty2 with | Prod(name1, lty1, value1), _ -> let lname1 = refresh_varname name1 in let lvalue1 = simple_subst name1 (Var(lname1)) value1 in mk_forall lname1 lty1 (hlp lvalue1 ty2 (Var(lname1) :: args1) args2) | _, Prod(name2, lty2, value2) -> let lname2 = refresh_varname name2 in let lvalue2 = simple_subst name2 (Var(lname2)) value2 in mk_forall lname2 lty2 (hlp ty1 lvalue2 args1 (Var(lname2) :: args2)) | _ -> mk_not (mk_eq (mk_long_app (Const(constr1)) (List.rev args1)) (mk_long_app (Const(constr2)) (List.rev args2))) in let rec hlp2 ctx ty1 ty2 args1 args2 = match ty1, ty2 with | Prod(name1, lty1, value1), _ -> let lname1 = refresh_varname name1 in let lvalue1 = simple_subst name1 (Var(lname1)) value1 in (hlp2 ((lname1, lty1) :: ctx) lvalue1 ty2 (Var(lname1) :: args1) args2) >>= fun r -> return (mk_forall lname1 type_any r) | _, Prod(name2, lty2, value2) -> let lname2 = refresh_varname name2 in let lvalue2 = simple_subst name2 (Var(lname2)) value2 in (hlp2 ((lname2, lty2) :: ctx) ty1 lvalue2 args1 (Var(lname2) :: args2)) >>= fun r -> return (mk_forall lname2 type_any r) | _ -> prop_to_formula ctx (mk_not (mk_eq (mk_long_app (Const(constr1)) (List.rev args1)) (mk_long_app (Const(constr2)) (List.rev args2)))) in begin if !opt_closure_guards || opt_discrimination_guards then prop_to_formula [] (hlp ty1 ty2 [] []) else hlp2 [] ty1 ty2 [] [] end >>= fun ax -> add_axiom (mk_axiom ("$_discrim_" ^ constr1 ^ "$" ^ constr2) ax) and add_inversion_axioms is_prop indname constrs = debug 2 (fun () -> print_endline ("add_inversion_axioms: " ^ indname)); let df = Defhash.find indname in match df with | (_, IndType(_, constrs, params_num), indtype, indsort) -> let args = Coq_typing.get_type_args indtype and vname = "X" ^ unique_id () in assert (params_num <= List.length args); let vty = mk_long_app (Const(indname)) (mk_vars args) in let lvars = args @ [(vname, vty)] in let params = mk_vars (Hhlib.take params_num args) in if is_prop then add_inversion_axioms0 (fun _ constrs _ _ -> mk_prop_inversion params indname args constrs) indname ("$_inversion_" ^ indname) [] lvars constrs (Var(vname)) (fun _ _ _ eqt -> eqt) else add_inversion_axioms0 (mk_inversion params) indname ("$_inversion_" ^ indname) [] lvars constrs (Var(vname)) begin fun _ targs2 _ eqt -> if opt_precise_inversion then mk_inversion_conjs params_num args targs2 [eqt] else eqt end | _ -> failwith "impossible" and add_def_axioms ((name, value, ty, srt) as def) = debug 2 (fun () -> print_endline ("add_def_axioms: " ^ name)); match value with | IndType(_, constrs, _) -> if srt = SortProp then (prop_to_formula [] ty) >>= fun r -> add_axiom (mk_axiom name r) else begin if Coq_typing.check_type_target_is_prop ty then begin begin if opt_prop_inversion_axioms && name <> "Coq.Init.Logic.eq" then add_inversion_axioms true name constrs else return () end >> if not opt_omit_toplevel_prop_typing_axioms then add_typing_axiom name ty else return () end else begin List.fold_left (fun acc c -> add_injection_axioms c >> acc) (return ()) constrs >> List.fold_left (fun acc (c1, c2) -> add_discrim_axioms c1 c2) (return ()) (Hhlib.mk_pairs constrs) >> add_typing_axiom name ty >> if opt_inversion_axioms then add_inversion_axioms false name constrs else return () end end | _ -> if srt = SortProp then begin prop_to_formula [] ty >>= fun r -> add_axiom (mk_axiom name r) end else begin add_typing_axiom name ty >> add_def_eq_axiom def end (***************************************************************************************) (* Axioms hash *) module Axhash = struct let axhash = Hashtbl.create 1024 let clear () = Hashtbl.clear axhash let add name lst = if Hashtbl.mem axhash name then failwith ("Axhash.add: " ^ name); Hashtbl.add axhash name lst let remove name = Hashtbl.remove axhash name let mem name = Hashtbl.mem axhash name let find name = try Hashtbl.find axhash name with Not_found -> failwith ("Axhash.find: " ^ name) end (***************************************************************************************) (* Translation *) let translate name = log 1 ("translate: " ^ name); let axs = extract_axioms (add_def_axioms (Defhash.find name)) in Hhlib.sort_uniq (fun x y -> Stdlib.compare (fst x) (fst y)) axs let retranslate lst = List.iter begin fun name -> if not (Axhash.mem name) then Axhash.add name (translate name) end lst let get_axioms lst = coq_axioms @ Hhlib.sort_uniq (fun x y -> Stdlib.compare (fst x) (fst y)) (List.concat (List.map Axhash.find lst)) let remove_def name = Defhash.remove name; Axhash.remove name let cleanup () = Defhash.clear (); Axhash.clear (); Hashing.clear coqterm_hash (******************************************************************************) let write_problem fname name deps = let axioms = get_axioms (name :: deps) in let oc = open_out fname in try Tptp_out.write_fol_problem (output_string oc) (List.remove_assoc name axioms) (name, List.assoc name axioms); close_out oc with e -> close_out oc; raise e coqhammer-1.3.2-8.20/src/plugin/coq_transl.mli000066400000000000000000000007211471571225200210210ustar00rootroot00000000000000(* Translation from Coq to FOL *) open Hh_term open Coqterms val reinit : hhdef list -> unit val translate : string (* name *) -> fol_axioms (* axioms *) val retranslate : string list (* names *) -> unit val get_axioms : string list (* definition names *) -> fol_axioms val remove_def : string (* name *) -> unit val cleanup : unit -> unit val write_problem : string (* file name *) -> string (* conjecture name *) -> string list (* dependency names *) -> unit coqhammer-1.3.2-8.20/src/plugin/coq_transl_opts.ml000066400000000000000000000047251471571225200217250ustar00rootroot00000000000000(* Coq translation options *) (* higher debug level implies more logging; 0 - no logging; 5 - highest *) let opt_debug_level = 0 (* should guards be generated from types of free variables? opt_closure_guards = true implies opt_lambda_guards = true *) let opt_closure_guards = ref false (* should guards be generated from types of lambda-bound variables? *) let opt_lambda_guards = false (* should guards be generated for injectivity axioms? *) let opt_injectivity_guards = false (* should guards be generated for discrimination axioms? *) let opt_discrimination_guards = false (* should Coq.Init.Logic.eq be translated to FOL equality? *) (* (currently, setting this to false will result in equality being unusable) *) let opt_translate_eq = true (* should the arity of constants be optimized as by Paulson & Meng? *) let opt_arity_optimization = true (* should arity of constants be optimized even if constant occurs with different arities? *) let opt_multiple_arity_optimization = true (* should a zero-arity version of a constant be always generated? *) let opt_always_zero_arity = true (* should inversion axioms be added for non-propositional inductive types? *) let opt_inversion_axioms = true (* should inversion axioms be added for inductive predicates? *) let opt_prop_inversion_axioms = true (* should simplify input? *) let opt_simpl = true (* should add induction principles? *) let opt_induction_principles = false (* should arity of type predicates be optimized? *) (* (never combine this with opt_multiple_arity_optimization) *) let opt_type_optimization = false (* should predicates be optimized? *) let opt_predicate_optimization = true (* should omit typing axioms for propositions? *) let opt_omit_prop_typing_axioms = false (* should omit typing axioms for top-level propositions? *) let opt_omit_toplevel_prop_typing_axioms = true (* should the typing predicate $HasType be used? *) (* (requires either opt_multiple_arity_optimization = true or opt_arity_optimization = false) *) let opt_hastype = true (* should the inversion axioms be more precise for non-propositional inductive types? *) let opt_precise_inversion = true (* should guard types be lifted? *) let opt_type_lifting = true (* should translate Set to Type? *) let opt_set_to_type = true (***************************************************************************************) (* Debugging *) let debug n f = if opt_debug_level >= n then f () else () let log n str = if opt_debug_level >= n then print_endline str else () coqhammer-1.3.2-8.20/src/plugin/coq_typing.ml000066400000000000000000000220571471571225200206650ustar00rootroot00000000000000(* Typing and type destruction *) open Hammer_lib open Coq_transl_opts open Coqterms (***************************************************************************************) (* Normalization by evaluation *) type coqvalue = N of coqneutral | PROD of coqterm Lazy.t * coqvalue_abstr | LAM of coqterm Lazy.t * coqvalue_abstr | FIX of coqterm Lazy.t * coqvalue Lazy.t and coqneutral = | VAR of string | CONST of string | APP of coqneutral * coqvalue Lazy.t | TERM of coqterm Lazy.t and coqvalue_abstr = string * coqterm Lazy.t * (coqvalue Lazy.t -> coqvalue) let rec reify v = let rec reify_neutral n = match n with | VAR x -> Var(x) | CONST c -> Const(c) | APP (x, y) -> App(reify_neutral x, reify (Lazy.force y)) | TERM t -> Lazy.force t in match v with | N x -> reify_neutral x | PROD(t, _) -> Lazy.force t | LAM(t, _) -> Lazy.force t | FIX(t, _) -> Lazy.force t (* evaluation to normal form *) let eval (tm : coqterm) : coqvalue = let rec eval (env : (string * coqvalue Lazy.t) list) (tm : coqterm) : coqvalue = debug 5 (fun () -> print_newline (); print_endline "eval"; print_coqterm tm; print_newline ()); let delay_subst env tm = if env = [] then lazy tm else lazy (dsubst (List.map (fun (n, v) -> (n, lazy (reify (Lazy.force v)))) env) tm) and delay_eval env tm = lazy (eval env tm) in let eval_abstr env (name, ty, value) = (name, delay_subst env ty, (fun x -> eval ((name, x) :: env) value)) in match tm with | Var(x) -> begin try Lazy.force (List.assoc x env) with Not_found -> N (VAR(x)) end | Const(c) -> begin let tm2 = try coqdef_value (Defhash.find c) with _ -> tm in if tm2 = tm then N (CONST c) else match tm2 with | IndType(_) -> N (CONST c) | _ -> eval [] tm2 end | App(x, y) -> let rec apply x y = match x with | LAM(_, (_, _, f)) -> f y | FIX(_, v) -> apply (Lazy.force v) y | N x2 -> N (APP(x2, y)) | _ -> failwith "apply" in apply (eval env x) (delay_eval env y) | Cast(x, y) -> eval env x | Lam a -> LAM(delay_subst env tm, eval_abstr env a) | Prod a -> PROD(delay_subst env tm, eval_abstr env a) | Let(value, (vname, ty, body)) -> eval ((vname, delay_eval env value) :: env) body | Case(indname, matched_term, return_type, params_num, branches) -> let rec eval_valapp v args = match args with | h :: t -> begin match v with | LAM(_, (_, _, f)) -> eval_valapp (f h) t | N n -> eval_valapp (N (APP(n, h))) t | _ -> failwith "eval_app" end | [] -> v and flatten_valapp v = let rec hlp n acc = match n with | (APP(x, y)) -> hlp x (y :: acc) | _ -> (N n, acc) in match v with | N n -> hlp n [] | _ -> (v, []) in begin let mt2 = eval env matched_term in try begin let (v, args) = flatten_valapp mt2 and df = try Defhash.find indname with _ -> raise Not_found in match df with | (_, IndType(_, constrs, _), indtype, indsort) -> begin match v with | (N (CONST c)) when List.mem c constrs -> let i = Hhlib.index c constrs in let (n, b) = List.nth branches i in if List.length args > n + params_num then begin print_coqterm tm; print_list print_string constrs; print_int i; print_newline (); print_int n; print_newline (); print_int params_num; print_newline (); failwith ("eval: bad number of constructor arguments: " ^ c) end else eval_valapp (eval env b) (Hhlib.drop params_num args) | _ -> N (TERM (delay_subst env (Case(indname, reify mt2, return_type, params_num, branches)))) end | _ -> failwith "impossible" end with Not_found -> N (TERM (delay_subst env (Case(indname, reify mt2, return_type, params_num, branches)))) end | Fix(cft, k, names, types, bodies) -> let rec mkenv m lst acc = match lst with | h :: t -> let fx = Fix(cft, m, names, types, bodies) in let v = if cft = CoqFix then lazy (FIX(delay_subst env fx, delay_eval env fx)) else lazy (N (TERM (delay_subst env fx))) in mkenv (m + 1) t ((h, v) :: acc) | [] -> acc in FIX(delay_subst env tm, lazy (eval (mkenv 0 names env) (List.nth bodies k))) | _ -> N (TERM (delay_subst env tm)) in eval [] tm (***************************************************************************************) (* Limited typechecking *) let rec check_prop args ctx tm = let is_prop_tgt args ty = let rec hlp args v = match v with | PROD(_, (_, _, f)) -> begin match args with | h :: args2 -> hlp args2 (f (lazy (eval h))) | _ -> false end | FIX(_, v2) -> hlp args (Lazy.force v2) | N (TERM tm) -> if args = [] then Lazy.force tm = SortProp else false | _ -> false in hlp args (eval ty) in debug 4 (fun () -> print_header "check_prop" tm ctx); match tm with | Var(x) -> begin try is_prop_tgt args (List.assoc x ctx) with Not_found -> print_list (fun (name, _) -> print_string name) (List.rev ctx); failwith ("check_prop: var not found: " ^ x) end | Const(c) -> begin try is_prop_tgt args (coqdef_type (Defhash.find c)) with _ -> false end | App(x, y) -> check_prop (y :: args) ctx x | Lam(vname, ty, body) -> begin (* NOTE: the lambda case is incomplete, but this should be enough in practice *) match args with | _ :: args2 -> check_prop args2 ((vname, ty) :: ctx) body | _ -> false end | Prod(vname, ty1, ty2) -> if args = [] then check_prop [] ((vname, ty1) :: ctx) ty2 else false | Cast(v, ty2) -> is_prop_tgt args ty2 | Case(indname, matched_term, return_type, params_num, branches) -> (* NOTE: this is incorrect if `params_num' is smaller than the number of arguments of the inductive type `indname' *) is_prop_tgt args (App(return_type, matched_term)) | Fix(_, k, names, types, bodies) -> is_prop_tgt args (List.nth types k) | Let(value, (name, ty, body)) -> check_prop args ctx (dsubst [(name, lazy (Cast(value, ty)))] body) | SortProp | SortSet | SortType -> false | Quant(_) | Equal(_) -> args = [] | _ -> failwith "check_prop" let check_prop ctx tm = match tm with | App(Const("~"), _) -> true | App(App(Const(c), _), _) when is_bin_logop c -> true | _ -> check_prop [] ctx tm let check_proof_var ctx name = let rec pom ctx name = match ctx with | (n, ty) :: ctx2 when n = name -> check_prop ctx2 ty | _ :: ctx2 -> pom ctx2 name | _ -> failwith "check_proof_var" in pom ctx name let check_type_target_is_prop ty = let rec hlp v = match v with | PROD(_, (name, _, f)) -> hlp (f (lazy (N (VAR name)))) | FIX(_, v2) -> hlp (Lazy.force v2) | N (TERM tm) -> Lazy.force tm = SortProp | _ -> false in hlp (eval ty) let check_type_target_is_type ty = let rec hlp v = match v with | PROD(_, (name, _, f)) -> hlp (f (lazy (N (VAR name)))) | FIX(_, v2) -> hlp (Lazy.force v2) | N (TERM tm) -> let tm2 = Lazy.force tm in tm2 = SortSet || tm2 = SortType | _ -> false in hlp (eval ty) let destruct_type_eval ty = let rec hlp v acc = match v with | PROD(_, (name, ty, f)) -> let name2 = refresh_varname name in hlp (f (lazy (N (VAR name2)))) ((name2, refresh_bvars (Lazy.force ty)) :: acc) | FIX(_, v2) -> hlp (Lazy.force v2) acc | _ -> (v, List.rev acc) in hlp (eval ty) [] let destruct_type ty = let (x, y) = destruct_type_eval ty in (reify x, y) let destruct_type_app ty = let (target, cargs) = destruct_type ty in let (tgt, targs) = flatten_app target in (tgt, targs, cargs) let get_type_args ty = snd (destruct_type_eval ty) let get_type_target ty = fst (destruct_type ty) let get_type_app_target ty = let (t, _, _) = destruct_type_app ty in t coqhammer-1.3.2-8.20/src/plugin/coq_typing.mli000066400000000000000000000014761471571225200210400ustar00rootroot00000000000000(* Typing and type destruction *) open Coqterms val check_prop : coqcontext -> coqterm -> bool val check_proof_var : coqcontext -> string (* variable name *) -> bool val check_type_target_is_prop : coqterm (* type *) -> bool val check_type_target_is_type : coqterm (* type *) -> bool (* In e.g. Pi x : alpha. Pi y : beta . c x y: args = [(x, alpha); (y, beta)]; target = c x y; app target = c; targs = [x; y] *) val destruct_type : coqterm (* type *) -> coqterm (* target *) * (string * coqterm) list (* args *) val destruct_type_app : coqterm (* type *) -> coqterm (* app target *) * coqterm list (* targs *) * (string * coqterm) list (* args *) val get_type_args : coqterm (* type *) -> (string * coqterm) list val get_type_target : coqterm (* type *) -> coqterm val get_type_app_target : coqterm (* type *) -> coqterm coqhammer-1.3.2-8.20/src/plugin/coqterms.ml000066400000000000000000000376551471571225200203600ustar00rootroot00000000000000(* coqterm datatype and helper functions *) open Hammer_lib open Coq_transl_opts open Hhlib type coqfixtype = CoqFix | CoqCoFix type coqterm = Var of string | Const of string | App of coqterm * coqterm | Lam of coqabstraction | Case of string (* name of inductive type matched on *) * coqterm (* matched term *) * coqterm (* return type: a lambda-abstraction that takes as its arguments the non-parameter arguments of the inductive definition and the term matched on *) * int (* params_num: number of parameters *) * (int * coqterm) list (* case branches: pairs (num of args (n), branch term); m-th branch on the list corresponds to the m-th constructor; arguments to each branch are the arguments of the corresponding constructor, with parameters omitted (parameters are the first params_num arguments of the constructor); each branch term is of the form \x_1...x_n . b where n is the number of arguments and b is the branch expression; it is always the case for each branch that params_num + n is the total number of arguments to the corresponding constructor *) | Cast of coqterm (* term *) * coqterm (* type *) | Fix of coqfixtype * int (* 0-based result index *) * string list (* name list *) * coqterm list (* type list *) * coqterm list (* body list *) | Let of coqterm (* value *) * coqabstraction | Prod of coqabstraction | IndType of string (* inductive type name *) * string list (* constructor names *) * int (* params_num *) | SortProp | SortSet | SortType | Quant of string (* "?" or "!" *) * coqabstraction | Equal of coqterm * coqterm and coqabstraction = string (* var name *) * coqterm (* var type *) * coqterm (* body *) type coqdef = (* coq global definition *) string (* name *) * coqterm (* value *) * coqterm (* type *) * coqterm (* sort *) type coqcontext = (string * coqterm) list (* fol is a coqterm for which is_fol holds *) type fol = coqterm type fol_axioms = (string * fol) list let is_fol tm = match tm with | Fix(_) | Case(_) | Lam(_) | Cast(_) | Prod(_) | IndType(_) | Let(_) | SortProp | SortSet | SortType -> false | _ -> true let mk_fun_ty ty1 ty2 = Prod("$Anonymous", ty1, ty2) let quant_type = Prod("T", SortType, mk_fun_ty (mk_fun_ty (Var("1")) SortProp) SortProp) let eq_type = Prod("T", SortType, mk_fun_ty (Var("1")) (mk_fun_ty (Var("2")) SortProp)) let logop_defs = [ ("&", Const("&"), mk_fun_ty SortProp (mk_fun_ty SortProp SortProp), SortType); ("|", Const("|"), mk_fun_ty SortProp (mk_fun_ty SortProp SortProp), SortType); ("=>", Const("=>"), mk_fun_ty SortProp (mk_fun_ty SortProp SortProp), SortType); ("<=>", Const("<=>"), mk_fun_ty SortProp (mk_fun_ty SortProp SortProp), SortType); ("~", Const("~"), mk_fun_ty SortProp SortProp, SortType); ("?", Const("?"), quant_type, SortType); ("!", Const("!"), quant_type, SortType); ("=", Const("="), eq_type, SortType); ("$True", Const("$True"), SortProp, SortType); ("$False", Const("$False"), SortProp, SortType); ("$Any", Const("$Any"), SortType, SortType); ("$Proof", Const("$Proof"), Const("$Any"), SortType) ] let type_any = Const("$Any") (***************************************************************************************) (* Miscellaneous helper functions *) let comp f g x = f (g x) let coqdef_name (name, _, _, _) = name let coqdef_value (_, value, _, _) = value let coqdef_type (_, _, ty, _) = ty let coqdef_sort (_, _, _, srt) = srt let coqdef_map f (name, value, ty, srt) = (name, f value, f ty, srt) let unique_id = let id = ref 0 in fun () -> begin incr id; if !id = 0 then failwith "unique_id"; string_of_int !id end let refresh_varname name = "var_" ^ name ^ "_" ^ unique_id () let mk_vars l = List.map (fun (x, _) -> Var(x)) l let mk_binop op x y = App(App(Const(op), x), y) let mk_uniop op x = App(Const(op), x) let mk_quant op var varty body = Quant(op, (var, varty, body)) let mk_hastype x y = if opt_hastype then App(App(Const "$HasType", x), y) else App(y, x) let mk_and = mk_binop "&" let mk_or = mk_binop "|" let mk_impl = mk_binop "=>" let mk_equiv = mk_binop "<=>" let mk_not = mk_uniop "~" let mk_forall = mk_quant "!" let mk_exists = mk_quant "?" let mk_eq x y = Equal(x, y) let is_bin_logop c = (c = "&" || c = "|" || c = "=>" || c = "<=>") let is_logop c = is_bin_logop c || c = "~" || c = "?" || c = "!" || c = "=" let strip_suffix name = try String.sub name 0 (String.rindex name '$') with Not_found -> name let rec mk_long f varlst body = match varlst with | (var, varty) :: t -> f var varty (mk_long f t body) | [] -> body let mk_long_forall = mk_long mk_forall let mk_long_exists = mk_long mk_exists let mk_long_lam = mk_long (fun var varty body -> Lam(var, varty, body)) let mk_long_prod = mk_long (fun var varty body -> Prod(var, varty, body)) let rec join_right f lst = match lst with | [x] -> x | x :: t -> f x (join_right f t) | _ -> failwith "join_right" let join_left f lst = let rec hlp lst acc = match lst with | [] -> acc | x :: t -> hlp t (f acc x) in match lst with | h :: t -> hlp t h | [] -> failwith "join_left" let mk_long_app left args = join_left (fun x y -> App(x, y)) (left :: args) let flatten_app tm = let rec hlp tm acc = match tm with | App(x, y) -> hlp x (y :: acc) | _ -> (tm, acc) in hlp tm [] let flatten_fol_quant op tm = let rec hlp tm acc = match tm with | Quant(op2, (vname, ty, body)) when op = op2 -> assert (ty = type_any); hlp body (vname :: acc) | _ -> (tm, List.rev acc) in hlp tm [] let mk_def name value ty srt = (name, value, ty, srt) let mk_axiom name thm = (name, thm) (* f n ctx acc tm: ctx -- list of (vname, vtype) pairs n -- length of ctx *) let map_fold_coqterm0 f acc tm = let rec do_map_fold n ctx acc tm = let map_fold_lst f n ctx lst acc2 = List.fold_right begin fun x (lst, acc) -> let (x2, acc2) = f n ctx acc x in (x2 :: lst, acc2) end lst ([], acc2) in match tm with | Var(_) -> f n ctx acc tm | Const(_) -> f n ctx acc tm | App(x, y) -> let (x2, acc2) = do_map_fold n ctx acc x in let (y2, acc3) = do_map_fold n ctx acc2 y in let tm2 = App(x2, y2) in f n ctx acc3 tm2 | Lam(name, ty, body) -> let (ty2, acc2) = do_map_fold n ctx acc ty in let (body2, acc3) = do_map_fold (n + 1) ((name, ty2) :: ctx) acc2 body in let tm2 = Lam(name, ty2, body2) in f n ctx acc3 tm2 | Case(indname, x, ty, npar, lst) -> let (x2, acc2) = do_map_fold n ctx acc x in let (ty2, acc3) = do_map_fold n ctx acc2 ty in let (lst2, acc4) = map_fold_lst begin fun n ctx acc (nargs, x) -> let (x2, acc2) = do_map_fold n ctx acc x in ((nargs, x2), acc2) end n ctx lst acc3 in let tm2 = Case(indname, x2, ty2, npar, lst2) in f n ctx acc4 tm2 | Cast(x, y) -> let (x2, acc2) = do_map_fold n ctx acc x in let (y2, acc3) = do_map_fold n ctx acc2 y in let tm2 = Cast(x2, y2) in f n ctx acc3 tm2 | Fix(cft, k, names, types, bodies) -> let (types2, acc2) = map_fold_lst do_map_fold n ctx types acc and m = List.length types in let ctx2 = Hhlib.rev_combine names types2 ctx in let rec mk_bodies2 bodies acc = match bodies with | b :: b2 -> let (bb, acc2) = mk_bodies2 b2 acc in let (x, acc3) = do_map_fold (n + m) ctx2 acc2 b in (x :: bb, acc3) | [] -> ([], acc) in let (bodies2, acc3) = mk_bodies2 bodies acc2 in let tm2 = Fix(cft, k, names, types2, bodies2) in f n ctx acc3 tm2 | Let(value, (name, ty, body)) -> let (value2, acc2) = do_map_fold n ctx acc value in let (ty2, acc3) = do_map_fold n ctx acc2 ty in let (body2, acc4) = do_map_fold (n + 1) ((name, ty2) :: ctx) acc3 body in let tm2 = Let(value2, (name, ty2, body2)) in f n ctx acc4 tm2 | Prod(name, ty, body) -> let (ty2, acc2) = do_map_fold n ctx acc ty in let (body2, acc3) = do_map_fold (n + 1) ((name, ty2) :: ctx) acc2 body in let tm2 = Prod(name, ty2, body2) in f n ctx acc3 tm2 | IndType(indname, constrs, params_num) -> f n ctx acc tm | SortProp | SortSet | SortType -> f n ctx acc tm | Quant(op, (vname, vtype, body)) -> let (vtype2, acc2) = do_map_fold n ctx acc vtype in let (body2, acc3) = do_map_fold (n + 1) ((vname, vtype2) :: ctx) acc2 body in let tm2 = Quant(op, (vname, vtype2, body2)) in f n ctx acc3 tm2 | Equal(x, y) -> let (x2, acc2) = do_map_fold n ctx acc x in let (y2, acc3) = do_map_fold n ctx acc2 y in let tm2 = Equal(x2, y2) in f n ctx acc3 tm2 in do_map_fold 0 [] acc tm let map_fold_coqterm f = map_fold_coqterm0 (fun _ ctx acc x -> f ctx acc x) let map_coqterm0 f tm = fst (map_fold_coqterm0 (fun n ctx acc x -> (f n ctx x, acc)) () tm) let map_coqterm f = map_coqterm0 (fun _ ctx x -> f ctx x) let fold_coqterm0 g acc tm = snd (map_fold_coqterm0 (fun n ctx acc x -> (x, g n ctx acc x)) acc tm) let fold_coqterm g acc = fold_coqterm0 (fun _ ctx acc x -> g ctx acc x) acc let get_const_names tm = let lst = fold_coqterm begin fun _ acc tm -> match tm with | Const(c) -> c :: acc | IndType(name, constrs, params_num) -> let lst = name :: constrs @ acc in if opt_induction_principles then (name ^ "_ind") :: lst else lst | _ -> acc end [] tm in Hhlib.sort_uniq (Stdlib.compare) lst let var_occurs vname tm = try fold_coqterm begin fun ctx acc tm -> match tm with | Var(v) when v = vname && not (List.mem_assoc v ctx) -> raise Exit | _ -> acc end false tm with Exit -> true let get_fvars ctx tm = let rec hlp vars tm acc = match vars with | ((name, ty) as v) :: t -> let tm2 = Lam(name, ty, tm) in if var_occurs name tm then hlp t tm2 (v :: acc) else hlp t tm2 acc | [] -> acc in hlp ctx tm [] let vars_to_ctx = List.rev let ctx_to_vars = List.rev let dsubst lst tm = let getname x i acc = try (List.assoc i acc, acc) with _ -> let name = refresh_varname x in (name, (i, name) :: acc) in let rename_abs n (name, ty, v) acc = try let name2 = List.assoc n acc in ((name2, ty, v), List.remove_assoc n acc) with _ -> (* we're in this case if Var(name) does not occur free *) ((refresh_varname name, ty, v), acc) in let rename_fix_names names n acc = let (names2, acc2, _) = List.fold_left begin fun (names2, acc, k) name -> try let name2 = List.assoc k acc in (name2 :: names2, List.remove_assoc k acc, k + 1) with _ -> (name :: names2, acc, k + 1) end ([], acc, n) names in (List.rev names2, acc2) in if lst = [] then tm else fst (map_fold_coqterm0 begin fun n ctx acc tm -> match tm with | Var(x) -> begin try let i = Hhlib.assoc_index x ctx in begin let (name, acc2) = getname x (n - i - 1) acc in (Var(name), acc2) end with _ -> begin match Hhlib.massoc x lst with | Some v -> (Lazy.force v, acc) | None -> (tm, acc) end end | Lam abs -> let (abs2, acc2) = rename_abs n abs acc in (Lam abs2, acc2) | Prod abs -> let (abs2, acc2) = rename_abs n abs acc in (Prod abs2, acc2) | Quant(op, abs) -> let (abs2, acc2) = rename_abs n abs acc in (Quant(op, abs2), acc2) | Let(value, abs) -> let (abs2, acc2) = rename_abs n abs acc in (Let(value, abs2), acc2) | Fix(cft, k, names, types, bodies) -> let (names2, acc2) = rename_fix_names names n acc in (Fix(cft, k, names2, types, bodies), acc2) | _ -> (tm, acc) end [] tm) let substvar vname tm = dsubst [(vname, lazy tm)] let refresh_bvars = substvar "dummy" (Var("dummy")) (* `simple_subst' assumes that the free variables of `value' cannot be captured *) let simple_subst vname value = map_coqterm begin fun ctx tm -> match tm with | Var(x) when x = vname && not (List.mem_assoc x ctx) -> value | _ -> tm end let subst_proof name ty = simple_subst name (Cast(Const("$Proof"), refresh_bvars ty)) let simpl = map_coqterm begin fun ctx tm -> match tm with | App(Lam(vname, _, body), x) -> substvar vname x body | _ -> tm end (***************************************************************************************) (* Printing *) let write_coqterm out tm = let rec write tm = match tm with | Var(x) -> out x | Const(c) -> out c | App(x, y) -> out "("; write x; out " @ "; write y; out ")" | Lam(vname, vtype, tm) -> out "^["; out vname; out " : "; write vtype; out "]: ("; write tm; out ")" | Case(indname, mtm, rt, nparams, branches) -> out "(match "; write mtm; out " : "; out indname; out " return "; write rt; out " with "; oiter out (fun (n, br) -> write br) " | " branches; out " end)" | Cast(tm, ty) -> out "("; write tm; out " : "; write ty; out ")" | Fix(cft, res, names, types, bodies) -> out "("; out (match cft with CoqFix -> "fix" | CoqCoFix -> "cofix"); out " "; out (string_of_int res); out " "; oiter out (fun ((n, ty), tm) -> out "("; out n; out " : "; write ty; out " := "; write tm; out ")") "; " (List.combine (List.combine names types) bodies); out ")" | Let(value, (name, ty, body)) -> out "let "; out name; out " : "; write ty; out " := "; write value; out " in "; write body | Prod(vname, vtype, tm) -> out "(Prod ("; out vname; out " : "; write vtype; out ")"; write tm; out ")" | IndType(indname, constrs, params_num) -> out "" | SortType -> out "Type" | SortSet -> out "Set" | SortProp -> out "Prop" | Quant(op, (vname, vtype, body)) -> out op; out "["; out vname; out " : "; write vtype; out "]: ("; write body; out ")" | Equal(x, y) -> out "("; write x; out " = "; write y; out ")" in write tm let print_coqterm tm = write_coqterm print_string tm; print_newline () let string_of_coqterm tm = let s = ref "" in let out s2 = s := !s ^ s2 in write_coqterm out tm; !s let print_list f lst = print_string "["; oiter print_string f ";\n" lst; print_endline "]" let print_var (name, ty) = print_string name; print_string " : "; write_coqterm print_string ty let print_ctx ctx = print_list print_var (List.rev ctx) let print_header_nonl str tm ctx = print_newline (); print_endline str; print_coqterm tm; print_ctx ctx let print_header str tm ctx = print_header_nonl str tm ctx; print_newline () coqhammer-1.3.2-8.20/src/plugin/defhash.ml000066400000000000000000000010161471571225200201030ustar00rootroot00000000000000(* Definitions hash *) open Coqterms let defhash = Hashtbl.create 1024 let add_lazy name x = if Hashtbl.mem defhash name then failwith ("duplicate global definition of " ^ name); Hashtbl.add defhash name (ref x) let add x = add_lazy (coqdef_name x) (lazy x) let remove name = Hashtbl.remove defhash name let clear () = Hashtbl.clear defhash let find name = try Lazy.force !(Hashtbl.find defhash name) with Not_found -> failwith ("Defhash.find: " ^ name) let mem name = Hashtbl.mem defhash name coqhammer-1.3.2-8.20/src/plugin/defhash.mli000066400000000000000000000003311471571225200202530ustar00rootroot00000000000000(* Definitions hash *) open Coqterms val add_lazy : string -> coqdef Lazy.t -> unit val add : coqdef -> unit val remove : string -> unit val clear : unit -> unit val find : string -> coqdef val mem : string -> bool coqhammer-1.3.2-8.20/src/plugin/dune000066400000000000000000000003551471571225200170320ustar00rootroot00000000000000(library (name hammer_plugin) (public_name coq-hammer.plugin) (synopsis "CoqHammer plugin") (libraries coq-core.plugins.ltac coq-core.vernac coq-hammer-tactics.lib coq-hammer-tactics.plugin )) (coq.pp (modules g_hammer)) coqhammer-1.3.2-8.20/src/plugin/features.ml000066400000000000000000000205301471571225200203210ustar00rootroot00000000000000open Hammer_lib open Hh_term open Hammer_errors (*********************************************************************************) (* feature options *) let opt_feature_polarity = true (*********************************************************************************) let extract_consts (t : hhterm) : string list = let rec pom t acc = match t with | Id _ -> acc | Comb(Comb(Id "$Construct", x), Id c) when not (Hhlib.string_begins_with c "Coq.Init.Logic.") -> pom x (c :: acc) | Comb(Id x, Id c) when (x = "$Const" || x = "$Ind") && not (Hhlib.string_begins_with c "Coq.Init.Logic.") -> (c :: acc) | Comb(x, y) -> pom y (pom x acc) in Hhlib.sort_uniq compare (pom t []) let rec top_feature = function | Comb(Comb(Id "$Construct", _), Id c) | Comb(Comb(Id "$Ind", Id c), _) | Comb(Id "$Const", Id c) -> c | Comb(Id "$Var", Id _) -> "X" | Comb(Id "$Rel", Id _) -> "X" | Comb(Comb(Id "$App", t), _) -> top_feature t | _ -> "" let extract_features (t : hhterm) : string list = let get_polarized c pos = if pos then c ^ "+" else c ^ "-" in let add_feature c pos acc = if opt_feature_polarity then c :: (get_polarized c pos) :: acc else c :: acc in let rec pom t pos acc = match t with | Id _ -> acc | Comb(Comb(Comb(Id "$Prod", Comb(Id "$Name", Id _)), vartype), body) -> pom vartype (not pos) (pom body pos acc) | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.and"), _)), args) -> pom args pos acc | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.or"), _)), args) -> pom args pos acc | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.not"), _)), args) -> pom args (not pos) acc | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.iff"), _)), args) -> pom args pos (pom args (not pos) acc) | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id "Coq.Init.Logic.ex"), _)), Comb(Comb(Id "$ConstrArray", _), Comb(Comb(Comb(Id "$Lambda", Comb(Id "$Name", Id _)), vartype), body))) -> pom vartype pos (pom body pos acc) | Comb(Comb(Id "$App", Comb(Id "$Const", Id "Coq.Init.Logic.all")), Comb(Comb(Id "$ConstrArray", _), Comb(Comb(Comb(Id "$Lambda", Comb(Id "$Name", Id _)), vartype), body))) -> pom vartype (not pos) (pom body pos acc) | Comb(Comb(Id "$Construct", x), Id c) when not (Hhlib.string_begins_with c "Coq.Init.Logic.") -> pom x pos (add_feature c pos acc) | Comb(Id x, Id c) when (x = "$Const" || x = "$Ind") && not (Hhlib.string_begins_with c "Coq.Init.Logic.") -> add_feature c pos acc | Comb(Comb(Id "$App", Comb(Id "$Const", Id c)), args) | Comb(Comb(Id "$App", Comb(Comb(Id "$Ind", Id c), _)), args) | Comb(Comb(Id "$App", Comb(Id "$Var", Id c)), args) | Comb(Comb(Id "$App", Comb(Comb(Id "$Construct", _), Id c)), args) -> let rec app_fea acc = function | Id "$ConstrArray" -> acc | Comb(moreargs, arg) -> begin match top_feature arg with | "" -> app_fea acc moreargs | s -> app_fea ((c ^ "-" ^ s) :: acc) moreargs end | _ -> failwith "impossible" in let feas = c :: app_fea [] args in pom args pos (List.fold_left (fun acc c -> add_feature c pos acc) acc feas) | Comb(x, y) -> pom y pos (pom x pos acc) in Hhlib.sort_uniq compare (pom t true []) let get_def_fea_term (def : hhdef) : hhterm = match def with | (_, true, _, ty, _) -> Lazy.force ty | (_, false, _, ty, prf) -> Comb(Lazy.force ty, Lazy.force prf) let get_def_features (def : hhdef) : string list = extract_features (get_def_fea_term def) let get_goal_features (hyps : hhdef list) (goal : hhdef) : string list = let rec pom lst = match lst with | [] -> get_def_fea_term goal | h :: t -> Comb(Comb(Comb(Id "$Prod", Comb(Id "$Name", Id "$Anonymous")), get_def_fea_term h), pom t) in extract_features (pom hyps) let get_deps (def : hhdef) : string list = match def with | (_, _, _, ty, prf) -> extract_consts (Comb(Lazy.force ty, Lazy.force prf)) let features_cache = Hashtbl.create 1024 let deps_cache = Hashtbl.create 1024 let cleanup () = Hashtbl.reset features_cache; Hashtbl.reset deps_cache let get_def_features_cached (def : hhdef) : string list = let name = get_hhdef_name def in try Hashtbl.find features_cache name with Not_found -> let fea = get_def_features def in Hashtbl.add features_cache name fea; fea let get_deps_cached (def : hhdef) : string list = let name = get_hhdef_name def in try Hashtbl.find deps_cache name with Not_found -> let deps = get_deps def in Hashtbl.add deps_cache name deps; deps let is_nontrivial (def : hhdef) : bool = let name = get_hhdef_name def in name <> "" && not (Hhlib.string_begins_with name "Coq.Init.Logic.") && (if !Opt.filter_program then not (Hhlib.string_begins_with name "Coq.Program.") else true) && (if !Opt.filter_classes then not (Hhlib.string_begins_with name "Coq.Classes.") else true) && (if !Opt.filter_hurkens then not (Hhlib.string_begins_with name "Coq.Logic.Hurkens.") else true) let extract (hyps : hhdef list) (defs : hhdef list) (goal : hhdef) : string = Msg.info "Extracting features..."; let fname = Filename.temp_file "predict" "" in let ocfea = open_out (fname ^ "fea") in let ocdep = open_out (fname ^ "dep") in let ocseq = open_out (fname ^ "seq") in let defs = List.filter is_nontrivial defs in if !Opt.debug_mode then Msg.info ("After filtering: " ^ string_of_int (List.length defs) ^ " Coq objects."); let names = Hhlib.strset_from_lst (List.map get_hhdef_name defs) in let write_def def = let name = get_hhdef_name def in output_string ocseq name; output_char ocseq '\n'; let fea = get_def_features_cached def in output_string ocfea name; output_char ocfea ':'; (* For empty features output empty quotes *) output_char ocfea '\"'; Hhlib.oiter (output_string ocfea) (output_string ocfea) "\", \"" fea; output_string ocfea "\"\n"; let pre_deps = get_deps_cached def in let deps = List.filter (fun a -> Hhlib.StringSet.mem a names) pre_deps in output_string ocdep name; output_char ocdep ':'; if deps <> [] then Hhlib.oiter (output_string ocdep) (output_string ocdep) " " deps; output_char ocdep '\n'; in List.iter write_def defs; close_out ocfea; close_out ocseq; close_out ocdep; let oc = open_out (fname ^ "conj") in let fea = get_goal_features hyps goal in output_char oc '\"'; Hhlib.oiter (output_string oc) (output_string oc) "\", \"" fea; output_string oc "\"\n"; close_out oc; fname let run_predict fname defs pred_num pred_method = let oname = Filename.temp_file ("coqhammer_out" ^ pred_method ^ string_of_int pred_num) "" in let cmd = !Opt.predict_path ^ " " ^ fname ^ "fea " ^ fname ^ "dep " ^ fname ^ "seq -n " ^ string_of_int pred_num ^ " -p " ^ pred_method ^ " 2>/dev/null < " ^ fname ^ "conj > " ^ oname in if !Opt.debug_mode || !Opt.gs_mode = 0 then Msg.info ("Running dependency prediction (" ^ pred_method ^ "-" ^ string_of_int pred_num ^ ")..."); if !Opt.debug_mode then Msg.info cmd; if Sys.command cmd <> 0 then begin raise (HammerError ("Dependency prediction failed.\nPrediction command: " ^ cmd)) end; let ic = open_in oname in try let predicts = Hhlib.strset_from_lst (Str.split (Str.regexp " ") (try input_line ic with End_of_file -> close_in ic; Sys.remove oname; raise (HammerError "Predictor did not return advice."))) in close_in ic; Sys.remove oname; List.filter (fun def -> Hhlib.StringSet.mem (get_hhdef_name def) predicts) defs with e -> close_in ic; Sys.remove oname; raise e let clean fname = if not !Opt.debug_mode then List.iter Sys.remove [fname; (fname ^ "fea"); (fname ^ "dep"); (fname ^ "seq"); (fname ^ "conj")] let predict (hyps : hhdef list) (defs : hhdef list) (goal : hhdef) : hhdef list = let fname = extract hyps defs goal in try let r = run_predict fname defs !Opt.predictions_num !Opt.predict_method in clean fname; r with e -> clean fname; raise e coqhammer-1.3.2-8.20/src/plugin/features.mli000066400000000000000000000017561471571225200205030ustar00rootroot00000000000000 open Hh_term val get_def_features : hhdef (* def *) -> string list val get_def_features_cached : hhdef (* def *) -> string list val get_goal_features : hhdef list (* hyps *) -> hhdef (* goal *) -> string list (* features *) (* `extract` extracts the features and dependencies into temporary files (to be used by the `predict` command) *) val extract : hhdef list (* hyps *) -> hhdef list (* defs *) -> hhdef (* goal *) -> string (* (temporary) file name *) val run_predict : string (* file name (from `extract`) *) -> hhdef list (* defs *) -> int (* pred_num *) -> string (* pred_method *) -> hhdef list (* predictions *) (* `clean` removes the temporary files created by `extract` *) val clean : string (* file name *) -> unit (* `predict` is essentially: extract + run_predict + clean *) val predict : hhdef list (* hyps *) -> hhdef list (* defs *) -> hhdef (* goal *) -> hhdef list (* predictions *) (* `cleanup` resets the feature and dependency cache *) val cleanup : unit -> unit coqhammer-1.3.2-8.20/src/plugin/g_hammer.mlg000066400000000000000000000036351471571225200204400ustar00rootroot00000000000000DECLARE PLUGIN "coq-hammer.plugin" { open Ltac_plugin open Stdarg open Tacarg let hammer_version_string = "CoqHammer 1.3.2 for Coq 8.20" open Hammer_main } TACTIC EXTEND Hammer_tac | [ "hammer" ] -> { hammer_tac () } END TACTIC EXTEND Predict_tac_1 | [ "predict" integer(n) ] -> { predict_tac n !Opt.predict_method } END TACTIC EXTEND Predict_tac_2 | [ "predict" integer(n) string(pred_method) ] -> { predict_tac n pred_method } END TACTIC EXTEND Hammer_features_tac | [ "hammer_features" ] -> { hammer_features_tac () } END { let hammer_cleanup () = Coq_transl.cleanup (); Features.cleanup () } VERNAC COMMAND EXTEND Hammer_plugin_cleanup CLASSIFIED AS SIDEFF | [ "Hammer_cleanup" ] -> { hammer_cleanup () } END VERNAC COMMAND EXTEND Hammer_plugin_print CLASSIFIED AS QUERY | [ "Hammer_print" string(name) ] -> { hammer_print name } END VERNAC COMMAND EXTEND Hammer_plugin_transl CLASSIFIED AS QUERY | [ "Hammer_transl" string(name) ] -> { hammer_transl name } END TACTIC EXTEND Hammer_plugin_transl_tac | [ "hammer_transl" ] -> { hammer_transl_tac () } END VERNAC COMMAND EXTEND Hammer_plugin_features CLASSIFIED AS QUERY | [ "Hammer_features" string(name) ] -> { hammer_features name } END VERNAC COMMAND EXTEND Hammer_plugin_features_cached CLASSIFIED AS QUERY | [ "Hammer_features_cached" string(name) ] -> { hammer_features_cached name } END VERNAC COMMAND EXTEND Hammer_plugin_objects CLASSIFIED AS QUERY | [ "Hammer_objects" ] -> { hammer_objects () } END { let hammer_version () = Msg.info hammer_version_string } VERNAC COMMAND EXTEND Hammer_plugin_version CLASSIFIED AS QUERY | [ "Hammer_version" ] -> { hammer_version () } END TACTIC EXTEND Hammer_hook_tac | [ "hammer_hook" string(prefix) string(name) ] -> { hammer_hook_tac prefix name } END TACTIC EXTEND Hammer_ptimeout_tac | [ "ptimeout" integer(n) tactic3(tac) ] -> { Timeout.ptimeout n (Tacinterp.tactic_of_value (Tacinterp.default_ist ()) tac) } END coqhammer-1.3.2-8.20/src/plugin/hammer_main.ml000066400000000000000000001170361471571225200207700ustar00rootroot00000000000000open Hammer_lib open Hammer_tactics open Hammer_errors open Sauto open Util open Names open Term open Constr open Context open Proofview.Notations open Ltac_plugin module Utils = Hhutils (***************************************************************************************) let mk_id x = Hh_term.Id x let mk_app x y = Hh_term.Comb(x, y) let mk_comb (x, y) = mk_app x y let tuple (l : Hh_term.hhterm list) = match l with | [] -> failwith "tuple: empty list" | [h] -> h | h :: t -> List.fold_left mk_app h t let hhterm_of_global glob = mk_id (Libnames.string_of_path (Nametab.path_of_global (Globnames.canonical_gr glob))) let hhterm_of_sort s = match Sorts.family s with | InSProp -> mk_id "$Prop" | InProp -> mk_id "$Prop" | InSet -> mk_id "$Set" | InType -> mk_id "$Type" | InQSort -> mk_id "$Type" let hhterm_of_constant c = tuple [mk_id "$Const"; hhterm_of_global (Names.GlobRef.ConstRef c)] let hhterm_of_inductive i = tuple [mk_id "$Ind"; hhterm_of_global (Names.GlobRef.IndRef i); mk_id (string_of_int (Inductiveops.inductive_nparams (Global.env()) i))] let hhterm_of_construct cstr = tuple [mk_id "$Construct"; hhterm_of_inductive (fst cstr); hhterm_of_global (Names.GlobRef.ConstructRef cstr)] let hhterm_of_var v = tuple [mk_id "$Var"; hhterm_of_global (Names.GlobRef.VarRef v)] let hhterm_of_intarray a = tuple ((mk_id "$IntArray") :: (List.map mk_id (List.map string_of_int (Array.to_list a)))) let hhterm_of_caseinfo ci = let {ci_ind = ci_ind; ci_npar = ci_npar; ci_cstr_ndecls = ci_cstr_ndecls; ci_cstr_nargs = ci_cstr_nargs; ci_pp_info = ci_pp_info; } = ci in tuple [mk_id "$CaseInfo"; hhterm_of_inductive ci_ind; mk_id (string_of_int ci_npar); hhterm_of_intarray ci_cstr_ndecls; hhterm_of_intarray ci_cstr_nargs] (* Unsafe *) let hhterm_of_name name = match name.binder_name with | Name.Name id -> tuple [mk_id "$Name"; mk_id (Id.to_string id)] | Name.Anonymous -> tuple [mk_id "$Name"; mk_id "$Anonymous"] let hhterm_of_namearray a = tuple ((mk_id "$NameArray") :: (List.map hhterm_of_name (Array.to_list a))) let hhterm_of_bool b = if b then mk_app (mk_id "$Bool") (mk_id "$True") else mk_app (mk_id "$Bool") (mk_id "$False") let rec hhterm_of (t : Constr.t) : Hh_term.hhterm = match Constr.kind t with | Rel n -> tuple [mk_id "$Rel"; mk_id (string_of_int n)] | Meta n -> raise (HammerError "Metavariables not supported.") | Var v -> hhterm_of_var v | Sort s -> tuple [mk_id "$Sort"; hhterm_of_sort s] | Cast (ty1,ck,ty2) -> tuple [mk_id "$Cast"; hhterm_of ty1; hhterm_of ty2] | Prod (na,ty,c) -> tuple [mk_id "$Prod"; hhterm_of_name na; hhterm_of ty; hhterm_of c] | Lambda (na,ty,c) -> tuple [mk_id "$Lambda"; hhterm_of_name na; hhterm_of ty; hhterm_of c] | LetIn (na,b,ty,c) -> tuple [mk_id "$LetIn"; hhterm_of_name na; hhterm_of b; hhterm_of ty; hhterm_of c] | App (f,args) -> tuple [mk_id "$App"; hhterm_of f; hhterm_of_constrarray args] | Const (c,u) -> hhterm_of_constant c | Proj (p,_,c) -> tuple [mk_id "$Proj"; hhterm_of_constant (Projection.constant p); hhterm_of_bool (Projection.unfolded p); hhterm_of c] | Evar (evk,cl) -> raise (HammerError "Existential variables not supported.") | Ind (ind,u) -> hhterm_of_inductive ind | Construct (ctr,u) -> hhterm_of_construct ctr | Case (ci,u,pms,p,iv,c,bl) -> let (ci, (p,_), iv, c, bl) = Inductive.expand_case (Global.env ()) (ci, u, pms, p, iv, c, bl) in tuple ([mk_id "$Case"; hhterm_of_caseinfo ci ; hhterm_of p; hhterm_of c; hhterm_of_constrarray bl]) | Fix (nvn,recdef) -> tuple [mk_id "$Fix"; hhterm_of_intarray (fst nvn); mk_id (string_of_int (snd nvn)); hhterm_of_precdeclaration recdef] | CoFix (n,recdef) -> tuple [mk_id "$CoFix"; mk_id (string_of_int n); hhterm_of_precdeclaration recdef] | Int n -> tuple [mk_id "$Int"; mk_id (Uint63.to_string n)] | Float n -> tuple [mk_id "$Float"; mk_id (Float64.to_string n)] | String _ -> raise (HammerError "Primitive strings not supported.") | Array _ -> raise (HammerError "Primitive arrays not supported.") and hhterm_of_constrarray a = tuple ((mk_id "$ConstrArray") :: List.map hhterm_of (Array.to_list a)) and hhterm_of_precdeclaration (a,b,c) = tuple [(mk_id "$PrecDeclaration") ; hhterm_of_namearray a; hhterm_of_constrarray b; hhterm_of_constrarray c] let get_type_of env evmap t = EConstr.to_constr evmap (Retyping.get_type_of env evmap (EConstr.of_constr t)) (* only for constants *) let hhproof_of c = begin match Global.body_of_constant Library.indirect_accessor c with | Some (b, _, _) -> hhterm_of b | None -> mk_id "$Axiom" end let hhdef_of_global env sigma glob_ref : (string * Hh_term.hhdef) = let glob_ref = Globnames.canonical_gr glob_ref in let ty = fst (Typeops.type_of_global_in_context env glob_ref) in let kind = get_type_of env sigma ty in let const = match glob_ref with | Names.GlobRef.ConstRef c -> hhterm_of_constant c | Names.GlobRef.IndRef i -> hhterm_of_inductive i | Names.GlobRef.ConstructRef cstr -> hhterm_of_construct cstr | Names.GlobRef.VarRef v -> hhterm_of_var v in let filename_aux = match glob_ref with | Names.GlobRef.ConstRef c -> Constant.to_string c | Names.GlobRef.IndRef i -> MutInd.to_string (fst i) | Names.GlobRef.ConstructRef cstr -> MutInd.to_string ((Hhlib.comp fst fst) cstr) | Names.GlobRef.VarRef v -> Id.to_string v in let term = match glob_ref with | Names.GlobRef.ConstRef c -> lazy (hhproof_of c) | _ -> lazy (mk_id "$Axiom") in let opaque = match glob_ref with | Names.GlobRef.ConstRef c -> Declareops.is_opaque (Global.lookup_constant c) | _ -> true in let filename = let l = Str.split (Str.regexp "\\.") filename_aux in Filename.dirname (String.concat "/" l) in (filename, (const, opaque, hhterm_of kind, lazy (hhterm_of ty), term)) let hhdef_of_hyp env sigma (id, maybe_body, ty) = let kind = get_type_of env sigma ty in let body = match maybe_body with | Some b -> lazy (hhterm_of b) | None -> lazy (mk_id "$Axiom") in let opaque = match maybe_body with | Some b -> false | None -> true in (mk_comb(mk_id "$Const", mk_id (Id.to_string id)), opaque, hhterm_of kind, lazy (hhterm_of ty), body) let get_hyps gl = let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let make_good = function | Context.Named.Declaration.LocalAssum(x, y) -> (x.binder_name, None, EConstr.to_constr sigma y) | Context.Named.Declaration.LocalDef(x, y, z) -> (x.binder_name, Some (EConstr.to_constr sigma y), EConstr.to_constr sigma z) in List.map (Hhlib.comp (hhdef_of_hyp env sigma) make_good) (Proofview.Goal.hyps gl) let get_goal gl = (mk_comb(mk_id "$Const", mk_id "_HAMMER_GOAL"), true, mk_comb(mk_id "$Sort", mk_id "$Prop"), lazy (hhterm_of (EConstr.to_constr (Proofview.Goal.sigma gl) (Proofview.Goal.concl gl))), lazy (mk_comb(mk_id "$Const", mk_id "_HAMMER_GOAL"))) let string_of t = Hh_term.string_of_hhterm (hhterm_of t) let string_of_hhdef_2 (filename, (const, hkind, hty, hterm)) = (filename, "tt(" ^ Hh_term.string_of_hhterm const ^ "," ^ Hh_term.string_of_hhterm hkind ^ "," ^ Hh_term.string_of_hhterm (Lazy.force hty) ^ "," ^ Hh_term.string_of_hhterm (Lazy.force hterm) ^ ").") let string_of_goal gl = string_of (EConstr.to_constr (Proofview.Goal.sigma gl) (Proofview.Goal.concl gl)) let my_search env = let save_in_list refl glob_ref env sigma c = refl := glob_ref :: !refl in let ans = ref [] in let filter_modules glob_ref = Opt.FilterSet.for_all (fun m -> not (Utils.match_globref m glob_ref)) (Opt.HammerFilterTable.v ()) in let filter glob_ref kind env sigma typ = (if !Opt.search_blacklist then Search.blacklist_filter glob_ref kind env sigma typ else true) && filter_modules glob_ref in let iter glob_ref kind env sigma typ = if filter glob_ref kind env sigma typ then save_in_list ans glob_ref env sigma typ in let env = Global.env () in let sigma = Evd.from_env env in let () = Search.generic_search env sigma iter in List.filter begin fun glob_ref -> try ignore (Typeops.type_of_global_in_context env glob_ref); true with _ -> false end (List.rev !ans) let unique_hhdefs hhdefs = let hash = Hashtbl.create 128 in List.filter begin fun (_, def) -> let name = Hh_term.get_hhdef_name def in if Hashtbl.mem hash name then false else begin Hashtbl.add hash name true; true end end hhdefs let get_defs env sigma : Hh_term.hhdef list = List.map snd (unique_hhdefs (List.map (hhdef_of_global env sigma) (my_search env))) let ltac_timeout tm tac (args: Tacinterp.Value.t list) = Timeout.ptimeout tm (Utils.ltac_eval tac args) let globref_to_econstr r = match r with | Names.GlobRef.VarRef(v) -> EConstr.mkVar v | Names.GlobRef.ConstRef(c) -> EConstr.mkConst c | Names.GlobRef.IndRef(i) -> EConstr.mkInd i | Names.GlobRef.ConstructRef(cr) -> EConstr.mkConstruct cr let globref_to_const r = match r with | Names.GlobRef.ConstRef(c) -> c | _ -> failwith "globref: not a constant" let globref_to_inductive r = match r with | Names.GlobRef.IndRef(i) -> i | _ -> failwith "globref: not an inductive type" let mk_lst_str pref lst = let get_name x = Hhlib.drop_prefix x "Top." in match lst with | [] -> "" | h :: t -> pref ^ " " ^ List.fold_right (fun x a -> get_name x ^ ", " ^ a) t (get_name h) let get_tac_args env sigma info = let deps = info.Provers.deps in let defs = info.Provers.defs in let inverts = Hhlib.sort_uniq Stdlib.compare (info.Provers.inversions @ info.Provers.cases) in let map_locate = List.map begin fun s -> try Nametab.locate (Libnames.qualid_of_string s) with Not_found -> Names.GlobRef.VarRef(Id.of_string s) end in let (deps, defs, inverts) = (map_locate deps, map_locate defs, map_locate inverts) in let filter_vars = List.filter (fun r -> match r with Names.GlobRef.VarRef(_) -> true | _ -> false) in let filter_nonvars = List.filter (fun r -> match r with Names.GlobRef.VarRef(_) -> false | _ -> true) in let filter_consts = List.filter (fun r -> match r with Names.GlobRef.ConstRef(_) -> true | _ -> false) in let (vars, deps) = (filter_vars deps, filter_nonvars deps) in let (deps, defs, inverts) = (List.map globref_to_econstr deps, List.map globref_to_const (filter_consts defs), List.map globref_to_inductive inverts) in (deps, defs, inverts) let check_goal_prop gl = let env = Proofview.Goal.env gl in let evmap = Proofview.Goal.sigma gl in let tp = EConstr.to_constr evmap (Retyping.get_type_of env evmap (Proofview.Goal.concl gl)) in match Constr.kind tp with | Sort s -> Sorts.family s = InProp | _ -> false (***************************************************************************************) let run_tactics deps defs inverts msg_success msg_fail msg_batch = let mkopts opts = let opts = if defs <> [] then { opts with s_unfolding = SSome defs } else opts in if inverts <> [] then { opts with s_inversions = SSome inverts } else opts in let use_deps = Generalize.generalize deps <*> Tacticals.tclDO (List.length deps) (Tactics.intro_move None Logic.MoveFirst) in let rhauto = usolve (use_deps <*> sauto (mkopts (hauto_s_opts ()))) and rqauto = usolve (use_deps <*> sauto (mkopts (qauto_s_opts ()))) and rhlqauto = usolve (use_deps <*> sauto (mkopts (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))))) and rhcrush = usolve (use_deps <*> scrush (mkopts (hauto_s_opts ()))) and rhfcrush = usolve (use_deps <*> fcrush (mkopts (hauto_s_opts ()))) and rqblast = usolve (use_deps <*> qblast (mkopts (default_s_opts ()))) and rhecrush = usolve (use_deps <*> ecrush (mkopts (hauto_s_opts ()))) and rlhauto = usolve (use_deps <*> sauto (mkopts (set_eager_opts false (hauto_s_opts ())))) and rhauto_l_nodrew = usolve (use_deps <*> sauto (mkopts { (set_eager_opts false (hauto_s_opts ())) with s_directed_rewriting = false})) and rhdauto6_lq = usolve (use_deps <*> sauto (mkopts { (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) with s_limit = 6; s_depth_cost_model = true })) and rhdauto6_lq_nodrew = usolve (use_deps <*> sauto (mkopts { (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) with s_limit = 6; s_depth_cost_model = true; s_directed_rewriting = false })) and rhdauto4 = usolve (use_deps <*> sauto (mkopts { (hauto_s_opts ()) with s_limit = 4; s_depth_cost_model = true })) and rlqdauto4 = usolve (use_deps <*> sauto (mkopts { (set_eager_opts false (qauto_s_opts ())) with s_limit = 4; s_depth_cost_model = true })) and rlqdauto4_nodrew = usolve (use_deps <*> sauto (mkopts { (set_eager_opts false (qauto_s_opts ())) with s_limit = 4; s_depth_cost_model = true; s_directed_rewriting = false })) and rhbauto = usolve (use_deps <*> sauto (mkopts (set_brefl_opts true (hauto_s_opts ())))) and rhbauto_nodrew = usolve (use_deps <*> sauto (mkopts { (set_brefl_opts true (hauto_s_opts ())) with s_directed_rewriting = false })) and rhbauto_norew = usolve (use_deps <*> sauto (mkopts (set_rew_opts false (set_brefl_opts true (hauto_s_opts ()))))) and rhauto_nodrew = usolve (use_deps <*> sauto (mkopts { (hauto_s_opts ()) with s_directed_rewriting = false })) and rhfcrush_nodrew = usolve (use_deps <*> fcrush (mkopts { (hauto_s_opts ()) with s_directed_rewriting = false })) and rhauto_norew = usolve (use_deps <*> sauto (mkopts (set_rew_opts false (hauto_s_opts ())))) and rhauto_lq_norew = usolve (use_deps <*> sauto (mkopts (set_quick_opts true (set_eager_opts false (set_rew_opts false (hauto_s_opts ())))))) and rhauto_lq_nodrew = usolve (use_deps <*> sauto (mkopts { (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) with s_directed_rewriting = false})) and rhbauto_lq = usolve (use_deps <*> sauto (mkopts (set_quick_opts true (set_eager_opts false (set_brefl_opts true (hauto_s_opts ())))))) and rhbauto_lq_nodrew = usolve (use_deps <*> sauto (mkopts { (set_quick_opts true (set_eager_opts false (set_brefl_opts true (hauto_s_opts ())))) with s_directed_rewriting = false })) and rhbfcrush = usolve (use_deps <*> fcrush (mkopts (set_brefl_opts true (hauto_s_opts ())))) and rhbfcrush_nodrew = usolve (use_deps <*> fcrush (mkopts { (set_brefl_opts true (hauto_s_opts ())) with s_directed_rewriting = false })) and rheauto = usolve (use_deps <*> sauto (mkopts { (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) with s_exhaustive = true; s_limit = 2; s_depth_cost_model = true })) and rhbauto4000 = usolve (use_deps <*> sauto (mkopts { (set_brefl_opts true (hauto_s_opts ())) with s_limit = 4000 })) and reauto = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Tacticals.tclSOLVE [ Eauto.gen_eauto [] (Some []) ]) and rcongruence = usolve (use_deps <*> scongruence (mkopts (default_s_opts ()))) and rfirstorder = usolve (use_deps <*> sfirstorder (mkopts (default_s_opts ()))) and rtrivial = usolve (use_deps <*> strivial (mkopts (default_s_opts ()))) and rreasy () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrreasy" []) and rrsimple () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrsimple" []) and rrcrush () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrcrush" []) and rryelles4 () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrryelles4" []) and rryelles6 () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrryelles6" []) and rrhreconstr4 () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrhreconstr4" []) and rrhreconstr6 () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrhreconstr6" []) and rryreconstr () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrryreconstr" []) and rrblast () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrblast" []) and rrscrush () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrscrush" []) and rrhrauto4 () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrhrauto4" []) and rrexhaustive1 () = usolve (use_deps <*> sinit (mkopts (hauto_s_opts ())) <*> Utils.ltac_apply "Reconstr.qrrexhaustive1" []) in let pretactics = [ (reauto, "srun eauto"); (rcongruence, "scongruence"); (rtrivial, "strivial"); (rfirstorder, "sfirstorder") ] in let tactics = [ [ (rhauto, "hauto"); (rqauto, "qauto"); (rhfcrush, "hfcrush"); (rhlqauto, "hauto lq: on") ]; [ (rhcrush, "hcrush"); (rhbauto, "hauto brefl: on"); (rhauto_lq_nodrew, "hauto lq: on drew: off"); (rhecrush, "hecrush") ]; [ (rhdauto6_lq, "hauto depth: 6 lq: on"); (rlqdauto4, "qauto depth: 4 l: on"); (rqblast, "qblast"); (rlhauto, "hauto l: on") ]; [ (rhauto_nodrew, "hauto drew: off"); (rhfcrush_nodrew, "hfcrush drew: off"); (rhdauto4, "hauto depth: 4"); (rhauto_l_nodrew, "hauto l: on drew: off") ]; [ (rhbauto_lq, "hauto brefl: on lq: on"); (rhbfcrush, "hfcrush brefl: on"); (rheauto, "hauto depth: 2 lq: on exh: on"); (rhbauto4000, "hauto limit: 4000 brefl: on") ]; [ (rhauto_norew, "hauto rew: off"); (rlqdauto4_nodrew, "qauto depth: 4 l: on drew: off"); (rhauto_lq_norew, "hauto lq: on rew: off"); (rhdauto6_lq_nodrew, "hauto depth: 6 lq: on drew: off") ]; [ (rhbauto_lq_nodrew, "hauto brefl: on lq: on drew: off"); (rhbfcrush_nodrew, "hfcrush brefl: on drew: off"); (rhbauto_nodrew, "hauto brefl: on drew: off"); (rhbauto_norew, "hauto brefl: on drew: off") ]; ] in let tactics = catch_errors begin fun () -> tactics @ [ [ (rreasy (), "srun Reconstr.rreasy"); (rrsimple (), "srun Reconstr.rrsimple"); (rrcrush (), "srun Reconstr.rrcrush"); (rryelles4 (), "srun Reconstr.rryelles4") ]; [ (rrblast (), "srun Reconstr.rrblast"); (rrscrush (), "srun Reconstr.rrscrush"); (rryreconstr (), "srun Reconstr.rryreconstr"); (rrhreconstr4 (), "srun Reconstr.rrhreconstr4") ]; [ (rryelles6 (), "srun Reconstr.rryelles6"); (rrhreconstr6 (), "srun Reconstr.rrhreconstr6"); (rrhrauto4 (), "srun Reconstr.rrhrauto4"); (rrexhaustive1 (), "srun Reconstr.rrexhaustive1") ] ] end (fun _ -> tactics) in let run limit tacs f_success f_failure = Hhpartac.partac limit (List.map fst tacs) begin fun k tac -> if k >= 0 then f_success (snd (List.nth tacs k)) tac else f_failure () end in let rec hlp k lst = match lst with | [] -> begin msg_fail (); Tacticals.tclIDTAC end | tacs :: ts -> msg_batch k; run !Opt.reconstr_timelimit tacs begin fun name tac -> msg_success name; tac end begin fun () -> hlp (k + 1) ts end in run 1 pretactics begin fun name tac -> msg_success name; tac end begin fun () -> hlp 1 tactics end let do_predict hyps deps goal = if !Opt.gs_mode > 0 then let greedy_sequence = [("CVC4 (nbayes-128)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "nbayes", 128); ("Vampire (knn-1024)", !Opt.vampire_enabled, Opt.vampire_enabled, "knn", 1024); ("CVC4 (knn-64)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "knn", 64); ("CVC4 (knn-256)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "knn", 256); ("Vampire (nbayes-64)", !Opt.vampire_enabled, Opt.vampire_enabled, "nbayes", 64); ("CVC4 (nbayes-256)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "nbayes", 256); ("Eprover (nbayes-64)", !Opt.eprover_enabled, Opt.eprover_enabled, "nbayes", 64); ("Z3 (nbayes-128)", !Opt.z3_enabled, Opt.z3_enabled, "nbayes", 128); ("Vampire (knn-64)", !Opt.vampire_enabled, Opt.vampire_enabled, "knn", 64); ("CVC4 (nbayes-32)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "nbayes", 32); ("CVC4 (nbayes-1024)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "nbayes", 1024); ("Z3 (nbayes-32)", !Opt.z3_enabled, Opt.z3_enabled, "nbayes", 32); ("Vampire (nbayes-128)", !Opt.vampire_enabled, Opt.vampire_enabled, "nbayes", 128); ("Eprover (knn-128)", !Opt.eprover_enabled, Opt.eprover_enabled, "knn", 128); ("Vampire (nbayes-32)", !Opt.vampire_enabled, Opt.vampire_enabled, "nbayes", 32); ("Z3 (knn-64)", !Opt.z3_enabled, Opt.z3_enabled, "knn", 64); ("Vampire (knn-256)", !Opt.vampire_enabled, Opt.vampire_enabled, "knn", 256); ("Eprover (nbayes-32)", !Opt.eprover_enabled, Opt.eprover_enabled, "nbayes", 32); ("Z3 (nbayes-64)", !Opt.z3_enabled, Opt.z3_enabled, "nbayes", 64); ("CVC4 (nbayes-64)", !Opt.cvc4_enabled, Opt.cvc4_enabled, "nbayes", 64); ("Eprover (nbayes-256)", !Opt.eprover_enabled, Opt.eprover_enabled, "nbayes", 256); ("Vampire (nbayes-1024)", !Opt.vampire_enabled, Opt.vampire_enabled, "nbayes", 1024); ("Z3 (nbayes-1024)", !Opt.z3_enabled, Opt.z3_enabled, "nbayes", 1024)] in let fname = Features.extract hyps deps goal in let jobs = List.map begin fun (pname, enabled, pref, pred_method, preds_num) _ -> if not enabled then exit 1; Opt.vampire_enabled := false; Opt.eprover_enabled := false; Opt.z3_enabled := false; Opt.cvc4_enabled := false; pref := true; Opt.parallel_mode := false; try let deps1 = Features.run_predict fname deps preds_num pred_method in (* All hypotheses are always passed to the ATPs (only deps are subject to premise selection) *) let info = Provers.predict deps1 hyps deps goal in Msg.info (pname ^ " succeeded"); info with | HammerError(msg) -> Msg.error ("Hammer error: " ^ msg); exit 1 | _ -> exit 1 end (Hhlib.take !Opt.gs_mode (List.filter (fun (_, enabled, _, _, _) -> enabled) greedy_sequence)) in let time = (float_of_int !Opt.atp_timelimit) *. 1.5 in Msg.info ("Running provers (" ^ string_of_int !Opt.gs_mode ^ " threads)..."); let clean () = Features.clean fname; if not !Opt.debug_mode then begin (* a hack *) ignore (Sys.command ("rm -f " ^ Filename.get_temp_dir_name () ^ "/coqhammer*")) end in let ret = try Parallel.run_parallel (fun _ -> ()) (fun _ -> ()) time jobs with e -> clean (); raise e in match ret with | None -> clean (); raise (HammerFailure "ATPs failed to find a proof.\nYou may try increasing the ATP time limit with 'Set Hammer ATPLimit N' (default: 20s).") | Some info -> begin let info = if List.length info.Provers.deps >= !Opt.minimize_threshold then Provers.minimize info hyps deps goal else info in clean (); let msg = Provers.prn_atp_info info in if msg <> "" then Msg.info msg; info end else (* Opts.gs_mode = 0 *) let deps1 = Features.predict hyps deps goal in Provers.predict deps1 hyps deps goal let try_sauto () = if !Opt.sauto_timelimit = 0 then Proofview.tclZERO (Failure "timeout") else Tacbest.run_best !Opt.sauto_timelimit (Tacbest.hammer_pretactics ()) [] begin fun str tac -> Msg.info ("Replace the hammer tactic with: " ^ str); tac end begin fun () -> Proofview.tclZERO (Failure "timeout") end (***************************************************************************************) let provers_detected = ref false let hammer_main_tac env sigma gl = let goal = get_goal gl in let hyps = get_hyps gl in let defs = get_defs env sigma in if !Opt.debug_mode then Msg.info ("Found " ^ string_of_int (List.length defs) ^ " accessible Coq objects."); let info = do_predict hyps defs goal in let (deps, defs, inverts) = get_tac_args env sigma info in let sdeps = List.map (Utils.constr_to_string sigma) deps and sdefs = List.map Utils.constant_to_string defs and sinverts = List.map Utils.inductive_to_string inverts in Msg.info ("Reconstructing the proof..."); run_tactics deps defs inverts begin fun tac -> Msg.info ("Tactic " ^ tac ^ " succeeded."); Msg.info ("Replace the hammer tactic with:\n\t" ^ tac ^ mk_lst_str " use:" sdeps ^ mk_lst_str " unfold:" sdefs ^ mk_lst_str " inv:" sinverts ^ ".") end begin fun () -> raise (HammerFailure "proof reconstruction failed.\nYou may try increasing the reconstruction time limit with 'Set Hammer ReconstrLimit N' (default: 5s).\nOther options are to disable the ATP which found this proof (Unset Hammer CVC4/Vampire/Eprover/Z3), or try to prove the goal manually using the displayed dependencies. Note that if the proof found by the ATP is inherently classical, it can never be reconstructed with CoqHammer's intuitionistic proof search procedure. As a last resort, you may also try enabling legacy reconstruction tactics with 'From Hammer Require Reconstr'.") end begin fun k -> Msg.info ("Trying reconstruction batch " ^ string_of_int k ^ "...") end let hammer_tac () = Proofview.Goal.enter begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in Proofview.tclORELSE (try_sauto ()) begin fun _ -> try_tactic begin fun () -> if not !provers_detected then begin Msg.info "Detecting provers..."; if not (Provers.detect ()) then Tacticals.tclZEROMSG (Pp.str "No ATPs found. See https://coqhammer.github.io for instructions on how to install the provers.") else begin provers_detected := true; hammer_main_tac env sigma gl end end else hammer_main_tac env sigma gl end end end let predict_tac n pred_method = try_goal_tactic begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let goal = get_goal gl in let hyps = get_hyps gl in let defs = get_defs env sigma in if !Opt.debug_mode then Msg.info ("Found " ^ string_of_int (List.length defs) ^ " accessible Coq objects."); if pred_method <> "knn" && pred_method <> "nbayes" then Msg.error "Invalid prediction method" else if n <= 0 then Msg.error "The number of predictions must be positive" else begin let old_pred_method = !Opt.predict_method and old_n = !Opt.predictions_num in Opt.predict_method := pred_method; Opt.predictions_num := n; let restore () = Opt.predict_method := old_pred_method; Opt.predictions_num := old_n in try let defs1 = Features.predict hyps defs goal in restore (); Msg.notice (Hhlib.sfold Hh_term.get_hhdef_name ", " defs1) with e -> restore (); raise e end; Tacticals.tclIDTAC end let hammer_features_tac () = try_goal_tactic begin fun gl -> let features = Features.get_goal_features (get_hyps gl) (get_goal gl) in Msg.notice (Hhlib.sfold (fun x -> x) ", " features); Tacticals.tclIDTAC end let hammer_print name = let env, sigma = let e = Global.env () in e, Evd.from_env e in try let glob = Utils.get_global name in let (_, (const, opaque, kind, ty, trm)) = hhdef_of_global env sigma glob in Msg.notice (Hh_term.string_of_hhterm const ^ " = "); Msg.notice (Hh_term.string_of_hhterm (Lazy.force trm)); Msg.notice (" : " ^ Hh_term.string_of_hhterm (Lazy.force ty)); Msg.notice (" : " ^ Hh_term.string_of_hhterm kind); if opaque then Msg.notice ("(opaque)") with Not_found -> Msg.error ("Not found: " ^ name) let hammer_transl name0 = let env, sigma = let e = Global.env () in e, Evd.from_env e in try let glob = Utils.get_global name0 in let (_, def) = hhdef_of_global env sigma glob in let name = Hh_term.get_hhdef_name def in Coq_transl.remove_def name; Coq_transl.reinit (get_defs env sigma); List.iter begin fun (n, a) -> if not (Hhlib.string_begins_with n "_HAMMER_") then Msg.notice (n ^ ": " ^ Coqterms.string_of_coqterm a) end (Coq_transl.translate name) with Not_found -> Msg.error ("Not found: " ^ name0) let hammer_transl_tac () = try_goal_tactic begin fun gl -> let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in let goal = get_goal gl in let hyps = get_hyps gl in let defs = get_defs env sigma in let name = Hh_term.get_hhdef_name goal in Coq_transl.remove_def name; List.iter (fun d -> Coq_transl.remove_def (Hh_term.get_hhdef_name d)) hyps; Coq_transl.reinit (goal :: hyps @ defs); List.iter begin fun (n, a) -> Msg.notice (n ^ ": " ^ Coqterms.string_of_coqterm a) end (Coq_transl.translate name); Tacticals.tclIDTAC end let hammer_features name = let env, sigma = let e = Global.env () in e, Evd.from_env e in try let glob = Utils.get_global name in let (_, def) = hhdef_of_global env sigma glob in Msg.notice (Hhlib.sfold (fun x -> x) ", " (Features.get_def_features def)) with Not_found -> Msg.error ("Not found: " ^ name) let hammer_features_cached name = let env, sigma = let e = Global.env () in e, Evd.from_env e in try let glob = Utils.get_global name in let (_, def) = hhdef_of_global env sigma glob in Msg.notice (Hhlib.sfold (fun x -> x) ", " (Features.get_def_features_cached def)) with Not_found -> Msg.error ("Not found: " ^ name) let hammer_objects () = let env, sigma = let e = Global.env () in e, Evd.from_env e in Msg.info ("Found " ^ string_of_int (List.length (get_defs env sigma)) ^ " accessible Coq objects.") let hammer_hook_tac prefix name = let premises = [("knn", 32); ("knn", 64); ("knn", 128); ("knn", 256); ("knn", 1024); ("nbayes", 32); ("nbayes", 64); ("nbayes", 128); ("nbayes", 256); ("nbayes", 1024)] and provers = [("vampire", Provers.extract_vampire_data); ("eprover", Provers.extract_eprover_data); ("z3", Provers.extract_z3_data); ("cvc4", Provers.extract_cvc4_data)] in let premise_prover_lst = Hhlib.mk_all_pairs premises provers in try_goal_tactic_nofail begin fun gl -> Msg.info ("Processing theorem " ^ name ^ "..."); try if check_goal_prop gl then begin let fopt = open_in "coqhammer.opt" in let str = input_line fopt in close_in fopt; if str = "check" then Tacticals.tclIDTAC else if str = "gen-atp" then begin let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in List.iter begin fun (met, n) -> let str = met ^ "-" ^ string_of_int n in Msg.info ("Parameters: " ^ str); Opt.predictions_num := n; Opt.predict_method := met; Opt.search_blacklist := false; Opt.filter_program := true; Opt.filter_classes := true; Opt.filter_hurkens := true; let dir = "atp/problems/" ^ str in ignore (Sys.command ("mkdir -p " ^ dir)); let goal = get_goal gl in let hyps = get_hyps gl in let defs = get_defs env sigma in let defs1 = Features.predict hyps defs goal in Provers.write_atp_file (dir ^ "/" ^ name ^ ".p") defs1 hyps defs goal end premises; Msg.info ("Done processing " ^ name ^ ".\n"); Tacticals.tclIDTAC end else if str = "reconstr" then begin let rec hlp lst = match lst with | ((prem_sel, prem_num), (prover, extract)) :: lst2 -> begin let str = prover ^ "-" ^ prem_sel ^ "-" ^ string_of_int prem_num in let dir = "atp/o/" ^ str and odir = "out/" ^ str in let fname = dir ^ "/" ^ name ^ ".p" and ofname = odir ^ "/" ^ name ^ ".out" in ignore (Sys.command ("mkdir -p " ^ odir)); if Sys.command ("grep -q -s \"SZS status Theorem\" \"" ^ fname ^ "\"") = 0 && not (Sys.file_exists ofname) then let pid = Unix.fork () in if pid = 0 then begin let env = Proofview.Goal.env gl in let sigma = Proofview.Goal.sigma gl in try try_fun begin fun () -> Msg.info ("Reconstructing theorem " ^ name ^ " (" ^ str ^ ")..."); let info = extract fname in let (deps, defs, inverts) = get_tac_args env sigma info in run_tactics deps defs inverts begin fun tac -> let msg = "Success " ^ name ^ " " ^ str ^ " " ^ tac in ignore (Sys.command ("echo \"" ^ msg ^ "\" > \"" ^ ofname ^ "\"")); Msg.info msg; exit 0 end begin fun () -> let msg = "Failure " ^ name ^ " " ^ str in ignore (Sys.command ("echo \"" ^ msg ^ "\" > \"" ^ ofname ^ "\"")); Msg.info msg; exit 1 end (fun _ -> ()) end (fun p -> Feedback.msg_notice p; exit 1) with _ -> exit 1 end else begin ignore (Unix.waitpid [] pid); hlp lst2 end else hlp lst2 end | [] -> Tacticals.tclIDTAC in hlp premise_prover_lst end else if str = "prove" then begin let odir = "out/" in let ofname = odir ^ "/" ^ name ^ ".out" in ignore (Sys.command ("mkdir -p " ^ odir)); if not (Sys.file_exists ofname) then let pid = Unix.fork () in if pid = 0 then try ignore (Sys.command ("echo \"Failure " ^ name ^ "\" > \"" ^ ofname ^ "\"")); try_fun begin fun () -> Msg.info ("Proving theorem " ^ name ^ "..."); Proofview.tclORELSE (Proofview.tclBIND (ltac_timeout !Opt.reconstr_timelimit "Tactics.fcrush" []) (fun _ -> let msg = "Success " ^ name in ignore (Sys.command ("echo \"" ^ msg ^ "\" > \"" ^ ofname ^ "\"")); Msg.info msg; exit 0)) begin fun _ -> let msg = "Failure " ^ name in ignore (Sys.command ("echo \"" ^ msg ^ "\" > \"" ^ ofname ^ "\"")); Msg.info msg; exit 1 end end (fun p -> Feedback.msg_notice p; exit 1) with _ -> exit 1 else begin ignore (Unix.waitpid [] pid); Tacticals.tclIDTAC end else Tacticals.tclIDTAC end else failwith ("Unknown option in coqhammer.opt: " ^ str) end else begin Msg.info "Goal not a proposition.\n"; Tacticals.tclIDTAC end with Sys_error s -> Msg.notice ("Warning: " ^ s); Tacticals.tclIDTAC end coqhammer-1.3.2-8.20/src/plugin/hammer_plugin.mlpack000066400000000000000000000002441471571225200221710ustar00rootroot00000000000000Hh_term Msg Timeout Coq_transl_opts Coqterms Defhash Coq_typing Hashing Coq_convert Tptp_out Coq_transl Opt Parallel Features Provers Reconstr Hammer_main G_hammer coqhammer-1.3.2-8.20/src/plugin/hashing.ml000066400000000000000000000060701471571225200201270ustar00rootroot00000000000000(* Author: Evan Marzion, modified by Lukasz Czajka *) open Hammer_lib open Coqterms open Hhlib open Coq_transl_opts type namesubst = (string * string) list (***************************************************************************************) (* Coqterm hashing *) let var i = "v_CANONICAL_" ^ (string_of_int i) (* creates a list of m canonical vars starting at n *) let vars n m = List.map var (range n (n+m)) (* substitutes all occ. of the name oldn with the name newn in term t *) let sub newn oldn t = substvar oldn (Var(newn)) t let subs pairs t = dsubst (List.map (fun (newn,oldn) -> (oldn, lazy (Var(newn)))) pairs) t (* canonical representation using variable renaming starting at n along with variable substitutions *) let rec can_aux n t = let f = can_aux n in match t with | Var x -> Var x | Const x -> Const x | App(t1,t2) -> App (f t1, f t2) | Lam(x,t1,t2) -> let v = var n in Lam(v, f t1, can_aux (n+1) (sub v x t2)) | Case(indt,t1,t2,m,cs) -> Case(indt, f t1, f t2, m, List.map (fun (p,u) -> (p, f u)) cs) | Cast(t1,t2) -> Cast(f t1, f t2) | Fix(t,i,xs,ts1,ts2) -> let m = List.length xs in let newvars = vars n m in let newbodies = List.map (fun b -> can_aux (n+m) (subs (zip (vars n m) xs) b)) ts2 in Fix(t, i, newvars, List.map f ts1, newbodies) | Let(t1,(x,t2,t3)) -> let v = var n in Let(f t1, (v,f t2, can_aux (n+1) (sub v x t2))) | Prod(x,t1,t2) -> let v = var n in Prod(v, f t1, can_aux (n+1) (sub v x t2)) | IndType(indt,xs,n) -> IndType(indt,xs,n) | SortProp -> SortProp | SortSet -> SortSet | SortType -> SortType | Quant(q,(x,t1,t2)) -> let v = var n in Quant(q,(v,f t1,can_aux (n+1) (sub v x t2))) | Equal(t1,t2) -> Equal(f t1,f t2) let canonical ctx tm = let rec can_ctx_aux acc subacc n ctx tm = match ctx with | [] -> (acc, can_aux n tm, subacc) | (x,tp) :: rest -> can_ctx_aux ((var n, tp) :: acc) ((var n, x) :: subacc) (n+1) (List.map (fun (y, t1) -> (y, sub (var n) x t1)) rest) (sub (var n) x tm) in can_ctx_aux [] [] 0 (List.rev ctx) tm type 'a lift_fun = (coqterm -> coqterm) -> 'a -> 'a type 'a coqterms_hash = (coqcontext * coqterm, 'a) Hashtbl.t * 'a lift_fun let create lift = (Hashtbl.create 128, lift) let clear tbl = Hashtbl.clear (fst tbl) let find_or_insert tbl ctx tm mk = debug 4 (fun () -> print_header "find_or_insert" tm ctx); let (tbl, lift) = tbl in let ctx' = vars_to_ctx (get_fvars ctx tm) in let (cctx,ctm,sigma) = canonical ctx' tm in debug 4 begin fun () -> print_header "canonical (result)" ctm cctx; print_list (fun (x,y) -> print_string ("(" ^ x ^ "," ^ y ^ ")")) sigma end; let revsigma = List.map (fun (x,y) -> (y,x)) sigma in try lift (subs revsigma) (Hashtbl.find tbl (cctx,ctm)) with _ -> let x = mk cctx ctm in Hashtbl.add tbl (cctx,ctm) x; lift (subs revsigma) x coqhammer-1.3.2-8.20/src/plugin/hashing.mli000066400000000000000000000015571471571225200203050ustar00rootroot00000000000000open Coqterms type namesubst = (string (* new name *) * string (* old name *)) list (* takes a context and term and returns them in canonical form, along with a list of free variable substitutions made. *) val canonical : coqcontext -> coqterm -> coqcontext * coqterm * namesubst type 'a lift_fun = (coqterm -> coqterm) -> ('a -> 'a) (* a hash table for coqterms which hashes up to alpha-equivalence; 'a = f coqterm for some functor f; the second element of the pair is the functor lifting function (fmap) *) type 'a coqterms_hash = (coqcontext * coqterm, 'a) Hashtbl.t * ('a lift_fun) val create : 'a lift_fun -> 'a coqterms_hash val clear : 'a coqterms_hash -> unit (* find_or_insert h ctx tm mk *) val find_or_insert : 'a coqterms_hash -> coqcontext -> coqterm -> (coqcontext -> coqterm -> 'a) (* function creating new value, called if tm not found *) -> 'a coqhammer-1.3.2-8.20/src/plugin/hh_term.ml000066400000000000000000000016631471571225200201370ustar00rootroot00000000000000type hhterm = Id of string (* may be a constant or variable *) | Comb of hhterm * hhterm type hhdef = hhterm (* "name" term; use get_hhdef_name to extract the name string *) * bool (* is opaque? *) * hhterm (* kind; Comb(Id "$Sort", Id "$Prop") if type is a proposition *) * hhterm Lazy.t (* type *) * hhterm Lazy.t (* term: definiens (value or proof term) *) let get_hhterm_name (c : hhterm) : string = match c with | Comb(Comb(Id "$Construct", _), Id constrname) -> constrname | Comb(Id "$Const", Id name) -> name | Comb(Comb(Id "$Ind", Id indname), _) -> indname | Comb(Id "$Var", Id name) -> name | _ -> "" let get_hhdef_name ((c, _, _, _, _) : hhdef) : string = get_hhterm_name c let hhdef_is_opaque ((_, opaque, _, _, _) : hhdef) : bool = opaque let rec string_of_hhterm t = match t with | Id(s) -> s | Comb(x, y) -> string_of_hhterm x ^ " @ (" ^ string_of_hhterm y ^ ")" coqhammer-1.3.2-8.20/src/plugin/msg.ml000066400000000000000000000002101471571225200172620ustar00rootroot00000000000000 open Feedback let error s = msg_notice (Pp.str ("Error: " ^ s)) let notice s = msg_notice (Pp.str s) let info s = msg_info (Pp.str s) coqhammer-1.3.2-8.20/src/plugin/opt.ml000066400000000000000000000136601471571225200173130ustar00rootroot00000000000000open Goptions let predictions_num = ref 1024 let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Predictions"]; optread=(fun ()->Some !predictions_num); optwrite= (function None -> predictions_num := 128 | Some i -> predictions_num := (max i 16))} in declare_int_option gdopt let sauto_timelimit = ref 1 let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"SAutoLimit"]; optread=(fun ()->Some !sauto_timelimit); optwrite= (function None -> sauto_timelimit := 1 | Some i -> sauto_timelimit := (max i 0))} in declare_int_option gdopt let atp_timelimit = ref 20 let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"ATPLimit"]; optread=(fun ()->Some !atp_timelimit); optwrite= (function None -> atp_timelimit := 10 | Some i -> atp_timelimit := (max i 0))} in declare_int_option gdopt let reconstr_timelimit = ref 5 let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"ReconstrLimit"]; optread=(fun ()->Some !reconstr_timelimit); optwrite= (function None -> reconstr_timelimit := 10 | Some i -> reconstr_timelimit := (max i 0))} in declare_int_option gdopt let minimize_threshold = ref 8 let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"MinimizationThreshold"]; optread=(fun ()->Some !minimize_threshold); optwrite= (function None -> minimize_threshold := 0 | Some i -> minimize_threshold := (max i 0))} in declare_int_option gdopt let gs_mode = ref 8 let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"GSMode"]; optread=(fun ()->Some !gs_mode); optwrite= (function None -> gs_mode := 16 | Some i -> gs_mode := i)} in declare_int_option gdopt let eprover_enabled = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Eprover"]; optread=(fun () -> !eprover_enabled); optwrite=(fun b -> eprover_enabled := b)} in declare_bool_option gdopt let vampire_enabled = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Vampire"]; optread=(fun () -> !vampire_enabled); optwrite=(fun b -> vampire_enabled := b)} in declare_bool_option gdopt let z3_enabled = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Z3"]; optread=(fun () -> !z3_enabled); optwrite=(fun b -> z3_enabled := b)} in declare_bool_option gdopt let cvc4_enabled = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"CVC4"]; optread=(fun () -> !cvc4_enabled); optwrite=(fun b -> cvc4_enabled := b)} in declare_bool_option gdopt let predict_path = ref "predict" let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"PredictPath"]; optread=(fun () -> !predict_path); optwrite=(fun s -> predict_path := s)} in declare_string_option gdopt let predict_method = ref "knn" let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"PredictMethod"]; optread=(fun () -> !predict_method); optwrite= begin fun s -> if s = "knn" || s = "nbayes" || s = "rforest" then predict_method := s else Msg.error "Invalid method. Available predict methods: knn, nbayes." end} in declare_string_option gdopt let parallel_mode = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Parallel"]; optread=(fun () -> !parallel_mode); optwrite=(fun b -> parallel_mode := b)} in declare_bool_option gdopt let debug_mode = ref false let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Debug"]; optread=(fun () -> !debug_mode); optwrite=(fun b -> debug_mode := b)} in declare_bool_option gdopt let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"ClosureGuards"]; optread=(fun () -> !Coq_transl_opts.opt_closure_guards); optwrite=(fun b -> Coq_transl_opts.opt_closure_guards := b)} in declare_bool_option gdopt let filter_program = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"FilterProgram"]; optread=(fun () -> !filter_program); optwrite=(fun b -> filter_program := b)} in declare_bool_option gdopt let filter_classes = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"FilterClasses"]; optread=(fun () -> !filter_classes); optwrite=(fun b -> filter_classes := b)} in declare_bool_option gdopt let filter_hurkens = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"FilterHurkens"]; optread=(fun () -> !filter_hurkens); optwrite=(fun b -> filter_hurkens := b)} in declare_bool_option gdopt let search_blacklist = ref true let _ = let gdopt= { optdepr=None; optstage = Interp; optkey=["Hammer";"Blacklist"]; optread=(fun () -> !search_blacklist); optwrite=(fun b -> search_blacklist := b)} in declare_bool_option gdopt module FilterSet = Set.Make(Names.ModPath) module HammerFilter = struct type t = Names.ModPath.t module Set = FilterSet let encode env = Nametab.locate_module let check_local _ _ = () let discharge x = x let subst = Mod_subst.subst_mp let printer m = Names.DirPath.print (Nametab.dirpath_of_module m) let key = ["Hammer"; "Filter"] let title = "Hammer Filter" let member_message m b = Pp.app (printer m) (if b then Pp.str " present" else Pp.str "absent") end module HammerFilterTable = MakeRefTable(HammerFilter) coqhammer-1.3.2-8.20/src/plugin/parallel.ml000066400000000000000000000040751471571225200203050ustar00rootroot00000000000000(* Parallel function invocation (for Unix) *) type ('a, 'b) sum = Inl of 'a | Inr of 'b | Err of int let run_parallel (progress_fn : 'a -> unit) (sec_fn : unit -> unit) time (lst : (('a -> unit) -> 'b) list) = let piper, pipew = Unix.pipe () in let start f = let pid = Unix.fork () in let oc = Unix.out_channel_of_descr pipew in if pid = 0 then begin try Unix.close piper; let progress_sub_fn a = output_value oc (Inl a); flush oc in let ret = f progress_sub_fn in output_value oc (Inr ret); flush oc; exit 0 with _ -> try output_value oc (Err (Unix.getpid ())); flush oc; exit 0 with _ -> exit 0 end; pid in let subprocesses = ref (List.map start lst) in let clean () = List.iter (fun i -> try Unix.kill i Sys.sigterm with _ -> ()) !subprocesses; Unix.close piper; List.iter (fun i -> try ignore (Unix.waitpid [] i) with _ -> ()) !subprocesses; List.iter (fun i -> try Unix.kill i Sys.sigkill with _ -> ()) !subprocesses; in try Unix.close pipew; let rec select desc time = if time <= 0. then 0. else let (r, _, _) = Unix.select [desc] [] [] 1. in if r <> [] then time else (sec_fn (); select desc (time -. 1.)) in Unix.set_nonblock piper; let inc = Unix.in_channel_of_descr piper in let rec ret time = if !subprocesses = [] then None else let interp time = function | Inl pr -> progress_fn pr; ret time | Inr ret -> Some (ret) | Err pid -> subprocesses := List.filter (fun i -> i <> pid) !subprocesses; ignore (Unix.waitpid [] pid); ret time in try interp time (input_value inc) with Sys_blocked_io | Unix.Unix_error _ -> let ntime = select piper time in if ntime > 0. then interp ntime (input_value inc) else None in let ret = ret time in clean (); (ret : 'b option) with | End_of_file -> clean (); None | e -> clean (); raise e coqhammer-1.3.2-8.20/src/plugin/provers.ml000066400000000000000000000367461471571225200202230ustar00rootroot00000000000000open Hammer_lib open Hammer_errors open Hh_term (* info about what the ATP used in the proof *) type atp_info = { deps : string list; (* dependencies: lemmas, theorems *) defs : string list; (* definitions (non-propositional) *) typings : string list; cases : string list; inversions : string list; injections : string list; discrims : (string * string) list; types : string list; (* (co)inductive types *) } (******************************************************************************) let unescape s = Scanf.unescaped (Scanf.unescaped s) let is_alpha = function 'A'..'Z'|'a'..'z'|'_' -> true | _ -> false let is_good_dep s = is_alpha (String.get s 0) && not (Hhlib.string_begins_with s "_HAMMER_") let remove_duplicates = Hhlib.sort_uniq Stdlib.compare let get_deps lst = List.filter is_good_dep lst let get_defs lst = List.filter is_good_dep (List.map (fun s -> String.sub s 6 (String.length s - 6)) (List.filter (fun s -> Hhlib.string_begins_with s "$_def_") lst)) let get_typings lst = List.filter is_good_dep (List.map (fun s -> String.sub s 9 (String.length s - 9)) (List.filter (fun s -> Hhlib.string_begins_with s "$_typeof_") lst)) let get_cases lst = remove_duplicates (List.filter is_good_dep (List.map begin fun s -> try let i = String.index s '$' in String.sub s 0 i with Not_found -> "$none" end (List.map (fun s -> String.sub s 7 (String.length s - 7)) (List.filter (fun s -> Hhlib.string_begins_with s "$_case_") lst)))) let get_inversions lst = List.filter is_good_dep (List.map (fun s -> String.sub s 12 (String.length s - 12)) (List.filter (fun s -> Hhlib.string_begins_with s "$_inversion_") lst)) let get_injections lst = List.filter is_good_dep (List.map (fun s -> String.sub s 6 (String.length s - 6)) (List.filter (fun s -> Hhlib.string_begins_with s "$_inj_") lst)) let get_discrims lst = List.filter (fun (x, y) -> is_good_dep x && is_good_dep y) (List.map begin fun s -> let s = String.sub s 10 (String.length s - 10) in let i = String.index s '$' in let s1 = String.sub s 0 i and s2 = String.sub s (i + 1) (String.length s - i - 1) in (s1, s2) end (List.filter (fun s -> Hhlib.string_begins_with s "$_discrim_") lst)) let get_types lst = remove_duplicates (List.filter is_good_dep (List.map begin fun s -> try let s = if Hhlib.string_begins_with s "$_inversion_" then String.sub s 12 (String.length s - 12) else if Hhlib.string_begins_with s "$_inj_" then String.sub s 6 (String.length s - 6) else if Hhlib.string_begins_with s "$_discrim_" then let s = String.sub s 10 (String.length s - 10) in let i = String.index s '$' in String.sub s 0 i else if Hhlib.string_begins_with s "$_case_" then let s = String.sub s 7 (String.length s - 7) in let i = String.index s '$' in String.sub s 0 i else "$none" in let tgt = Coq_typing.get_type_app_target (Coqterms.coqdef_type (Defhash.find s)) in match tgt with | Coqterms.Const(x) -> x | _ -> "$none" with _ -> "$none" end lst)) let get_atp_info names = { deps = get_deps names; defs = get_defs names; typings = get_typings names; cases = get_cases names; inversions = get_inversions names; injections = get_injections names; discrims = get_discrims names; types = get_types names } let prn_atp_info info = let drop_prefixes x = Hhlib.drop_prefix (Hhlib.drop_prefix x "Top.") "Coq." in let prn_lst prompt lst = match lst with | [] -> "" | h :: t -> prompt ^ List.fold_right (fun x a -> drop_prefixes x ^ ", " ^ a) t (drop_prefixes h) in let nl b = if b then "\n" else "" in let b1 = info.deps <> [] in let b2 = b1 || info.defs <> [] in let b3 = b2 || info.inversions <> [] in prn_lst "- dependencies: " info.deps ^ prn_lst (nl b1 ^ "- definitions: ") info.defs ^ prn_lst (nl b2 ^ "- inversions: ") info.inversions ^ prn_lst (nl b3 ^ "- cases: ") info.cases module StringMap = Map.Make(String) let get_atp_deps deps = let deps_map = List.fold_left (fun a x -> StringMap.add (get_hhdef_name x) x a) StringMap.empty deps in fun info -> List.map (fun x -> StringMap.find x deps_map) (List.sort_uniq Stdlib.compare (List.filter (fun x -> StringMap.mem x deps_map) (info.deps @ info.defs @ info.typings @ info.types))) (******************************************************************************) let invoke_prover prover_name cmd outfile = if !Opt.debug_mode then Msg.info cmd; let tm = Unix.gettimeofday () in let ret = Sys.command cmd in if ret = 0 then Sys.command ("grep -q -s \"SZS status Theorem\" " ^ outfile) = 0 else if ret <> 137 && Unix.gettimeofday () -. tm <= 1. then (* the second branch is a hack *) begin Msg.error ("Error running " ^ prover_name ^ "."); if !Opt.debug_mode then Msg.info ("Return code: " ^ string_of_int ret); false end else false let call_eprover infile outfile = let tmt = string_of_int !Opt.atp_timelimit in let tmt2 = string_of_int (!Opt.atp_timelimit + 1) in let cmd = "htimeout " ^ tmt2 ^ " eprover -s --cpu-limit=" ^ tmt ^ " --auto-schedule -R --print-statistics -p --tstp-format \"" ^ infile ^ "\" 2>/dev/null | grep \"file[(]'\\|# SZS\" > \"" ^ outfile ^ "\"" in invoke_prover "eprover" cmd outfile let extract_eprover_data outfile = try let ic = open_in outfile in let rec pom acc = try let ln = input_line ic in if String.get ln 0 = '#' then pom acc else if String.sub ln ((String.index ln ',') + 2) 5 = "axiom" then let i = String.rindex ln ',' + 2 in let j = String.rindex ln '\'' in let name = unescape (String.sub ln (i + 1) (j - i - 1)) in pom (name :: acc) else pom acc with | End_of_file -> acc | Not_found | Invalid_argument(_) -> pom acc in let names = pom [] in close_in ic; get_atp_info names with _ -> raise (HammerError "Failed to extract EProver data") let call_z3 infile outfile = let tmt = string_of_int !Opt.atp_timelimit in let tmt2 = string_of_int (!Opt.atp_timelimit + 1) in let cmd = "htimeout " ^ tmt2 ^ " z3_tptp -c -t:" ^ tmt ^ " -file:" ^ infile ^ " 2>/dev/null > " ^ outfile in invoke_prover "z3_tptp" cmd outfile let extract_z3_data outfile = try let ic = open_in outfile in ignore (input_line ic); let ln = String.trim (input_line ic) in let s = String.sub ln 13 (String.length ln - 2 - 13) in let names = List.map unescape (Str.split (Str.regexp "'| |'") s) in close_in ic; get_atp_info names with _ -> raise (HammerError "Failed to extract Z3 data") let call_vampire infile outfile = let tmt = string_of_int !Opt.atp_timelimit in let tmt2 = string_of_int (!Opt.atp_timelimit + 1) in let cmd = "htimeout " ^ tmt2 ^ " vampire --mode casc -t " ^ tmt ^ " --proof tptp --output_axiom_names on " ^ infile ^ " 2>/dev/null | grep \"file[(]'\\|% SZS\" > " ^ outfile in invoke_prover "vampire" cmd outfile let extract_vampire_data outfile = try let ic = open_in outfile in let rec pom acc = try let ln = input_line ic in if String.get ln 0 = '%' then pom acc else let i = String.rindex ln ',' + 1 in let j = String.rindex ln '\'' in let name = unescape (String.sub ln (i + 1) (j - i - 1)) in if name <> "HAMMER_GOAL" then pom (name :: acc) else pom acc with | End_of_file -> acc | Not_found | Invalid_argument(_) -> pom acc in let names = pom [] in close_in ic; get_atp_info names with _ -> raise (HammerError "Failed to extract Vampire data") let call_cvc4 infile outfile = let tmt = string_of_int !Opt.atp_timelimit in let tmt2 = string_of_int (!Opt.atp_timelimit + 1) in let cmd = "htimeout " ^ tmt2 ^ " cvc4 --tlimit " ^ tmt ^ " --dump-unsat-cores-full " ^ infile ^ " > " ^ outfile in invoke_prover "cvc4" cmd outfile let extract_cvc4_data outfile = try let ic = open_in outfile in let rec pom acc = try let ln = input_line ic in if (String.get ln 0 = '%') then pom acc else let i = String.index ln '\'' in let j = String.rindex ln '\'' in let name = unescape (String.sub ln (i + 1) (j - i - 1)) in if name <> "HAMMER_GOAL" then pom (name :: acc) else pom acc with | End_of_file -> acc | Not_found | Invalid_argument(_) -> pom acc in let names = pom [] in close_in ic; get_atp_info names with _ -> raise (HammerError "Failed to extract CVC4 data") (******************************************************************************) let provers = [(Opt.vampire_enabled, "Vampire", call_vampire, extract_vampire_data); (Opt.z3_enabled, "Z3", call_z3, extract_z3_data); (Opt.eprover_enabled, "EProver", call_eprover, extract_eprover_data); (Opt.cvc4_enabled, "CVC4", call_cvc4, extract_cvc4_data)] let call_prover (enabled, pname, call, extract) fname ofname cont = let clean () = if not !Opt.debug_mode && Sys.file_exists ofname then Sys.remove ofname in if !enabled then try begin if !Opt.debug_mode || !Opt.gs_mode = 0 then Msg.info ("Running " ^ pname ^ "..."); if call fname ofname then begin let info = extract ofname in clean (); (pname, info) end else begin if !Opt.debug_mode || !Opt.gs_mode = 0 then Msg.info (pname ^ " failed"); clean (); cont () end end with e -> clean (); raise e else cont () let call_provers fname ofname = let rec pom lst = match lst with | [] -> raise (HammerFailure "ATPs failed to find a proof") | h :: t -> call_prover h fname ofname (fun () -> pom t) in pom provers let call_provers_par fname ofname = let jobs = List.map begin fun ((_, pname, _, _) as h) _ -> call_prover h fname (ofname ^ "." ^ pname) (fun () -> exit 1) end provers in let time = float_of_int !Opt.atp_timelimit in match Parallel.run_parallel (fun _ -> ()) (fun _ -> ()) time jobs with | None -> raise (HammerFailure "ATPs failed to find a proof") | Some x -> x (******************************************************************************) (* Main functions *) let write_atp_file fname deps1 hyps deps goal = let name = Hh_term.get_hhdef_name goal in let depnames = List.map Hh_term.get_hhdef_name (hyps @ deps1) in Coq_transl.remove_def name; List.iter (fun d -> Coq_transl.remove_def (Hh_term.get_hhdef_name d)) hyps; Coq_transl.reinit (goal :: hyps @ deps); if !Opt.debug_mode || !Opt.gs_mode = 0 then Msg.info ("Translating the problem to FOL..."); Coq_transl.retranslate (name :: depnames); if !Opt.debug_mode then Msg.info ("Writing translated problem to file '" ^ fname ^ "'..."); Coq_transl.write_problem fname name depnames let minimize info hyps deps goal = if !Opt.debug_mode then Msg.info (prn_atp_info info); Msg.info "Minimizing dependencies..."; let get_atp_deps = get_atp_deps deps in let rec pom pname1 info = let fname = Filename.temp_file "coqhammer" ".p" in write_atp_file fname (get_atp_deps info) hyps deps goal; let ofname = fname ^ ".out" in let clean () = if not !Opt.debug_mode then begin if Sys.file_exists fname then Sys.remove fname; if Sys.file_exists ofname then Sys.remove ofname end in let jobs = List.map begin fun ((_, pname, _, _) as h) _ -> if pname <> pname1 then begin let (pname2, info2) = call_prover h fname (ofname ^ "." ^ pname) (fun () -> exit 1) in if List.length info2.deps < List.length info.deps || List.length info2.defs < List.length info.defs then (pname2, info2) else exit 1 end else exit 1 end provers in let time = (float_of_int !Opt.atp_timelimit) in match Parallel.run_parallel (fun _ -> ()) (fun _ -> ()) time jobs with | None -> begin if !Opt.debug_mode then begin if pname1 = "" then Msg.info "Minimization failed" else Msg.info "Minimization succeeded" end; clean (); info end | Some (pname2, info2) -> clean (); pom pname2 info2 in pom "" info let predict deps1 hyps deps goal = let fname = Filename.temp_file "coqhammer" ".p" in write_atp_file fname deps1 hyps deps goal; let ofname = fname ^ ".out" in let clean () = if not !Opt.debug_mode then begin if Sys.file_exists fname then Sys.remove fname; if Sys.file_exists ofname then Sys.remove ofname end in let call = if !Opt.parallel_mode then call_provers_par else call_provers in try let (pname, info) = call fname ofname in clean (); if !Opt.gs_mode = 0 then begin Msg.info(pname ^ " succeeded"); let info = if List.length info.deps >= !Opt.minimize_threshold then minimize info hyps deps goal else info in let msg = prn_atp_info info in if msg <> "" then Msg.info msg; info end else info with e -> clean (); raise e (******************************************************************************) let detect_eprover () = if Sys.command "eprover --version 2>&1 >/dev/null" = 0 then begin Msg.info "Eprover found"; Opt.eprover_enabled := true; true end else begin Msg.info "Eprover not found"; Opt.eprover_enabled := false; false end let detect_vampire () = if Sys.command "vampire --version 2>&1 >/dev/null" = 0 then begin Msg.info "Vampire found"; Opt.vampire_enabled := true; true end else begin Msg.info "Vampire not found"; Opt.vampire_enabled := false; false end let detect_z3 () = if Sys.command "z3_tptp -h 2>&1 >/dev/null" = 0 then begin Msg.info "Z3 found"; Opt.z3_enabled := true; true end else begin Msg.info "Z3 not found"; Opt.z3_enabled := false; false end let detect_cvc4 () = if Sys.command "cvc4 --version 2>&1 >/dev/null" = 0 then begin Msg.info "CVC4 found"; Opt.cvc4_enabled := true; true end else begin Msg.info "CVC4 not found"; Opt.cvc4_enabled := false; false end let detect () = let b1 = detect_eprover () and b2 = detect_vampire () and b3 = detect_z3 () and b4 = detect_cvc4 () in b1 || b2 || b3 || b4 coqhammer-1.3.2-8.20/src/plugin/provers.mli000066400000000000000000000023521471571225200203560ustar00rootroot00000000000000open Hh_term (* info about what the ATP used in the proof *) type atp_info = { deps : string list; (* dependencies: lemmas, theorems *) defs : string list; (* definitions (non-propositional) *) typings : string list; cases : string list; inversions : string list; injections : string list; discrims : (string * string) list; types : string list; (* (co)inductive types *) } val prn_atp_info : atp_info -> string val extract_eprover_data : string (* file name *) -> atp_info val extract_vampire_data : string (* file name *) -> atp_info val extract_z3_data : string (* file name *) -> atp_info val extract_cvc4_data : string (* file name *) -> atp_info val write_atp_file : string (* file name *) -> hhdef list (* filtered deps *) -> hhdef list (* hyps *) -> hhdef list (* all deps *) -> hhdef (* goal *) -> unit val minimize : atp_info -> hhdef list (* hyps *) -> hhdef list (* all deps *) -> hhdef (* goal *) -> atp_info val predict : hhdef list (* filtered deps *) -> hhdef list (* hyps *) -> hhdef list (* all deps *) -> hhdef (* goal *) -> atp_info (* Detect ATPs and set the hammer options in opt.ml (?_enabled) accordingly. Returns true if at least one prover found, false otherwise. *) val detect : unit -> bool coqhammer-1.3.2-8.20/src/plugin/timeout.ml000066400000000000000000000022321471571225200201700ustar00rootroot00000000000000(* Proofview.tclTIMEOUT is incorrect because of a bug in OCaml runtime. This file contains a timeout implementation based on Unix.fork and Unix.sleep. See: https://caml.inria.fr/mantis/view.php?id=7709 https://caml.inria.fr/mantis/view.php?id=4127 https://github.com/coq/coq/issues/7430 https://github.com/coq/coq/issues/7408 *) (* ptimeout implements timeout using fork and sleep *) let ptimeout n tac = let pid = Unix.fork () in if pid = 0 then begin (* the worker *) Proofview.tclOR (Proofview.tclBIND tac (fun _ -> exit 0)) (fun _ -> exit 1) end else begin let pid2 = Unix.fork () in if pid2 = 0 then begin (* the watchdog *) Unix.sleep n; Unix.kill pid Sys.sigterm; exit 0 end; let clean () = ignore (try Unix.kill pid2 Sys.sigterm with _ -> ()) in try let (_, status) = Unix.waitpid [] pid in match status with | Unix.WEXITED 0 -> clean (); tac | _ -> clean(); Proofview.tclZERO Logic_monad.Tac_Timeout with | _ -> clean (); Proofview.tclZERO Logic_monad.Tac_Timeout end coqhammer-1.3.2-8.20/src/plugin/tptp_out.ml000066400000000000000000000333621471571225200203700ustar00rootroot00000000000000(* Writing already translated problems to FOF TPTP format *) open Hammer_lib open Coqterms open Coq_transl_opts open Hhlib let const_hash = Hashtbl.create 100 let pred_hash = Hashtbl.create 100 let mconst_hash = Hashtbl.create 100 let tconst_hash = Hashtbl.create 100 (******************************************************************************) (* Constant hashes *) let rec add_consts_to_hash tm = match tm with | Var(_) -> () | Const(c) -> Hashtbl.replace const_hash c 0 | App(_) -> begin let (x, args) = flatten_app tm in begin match x with | Const(c) -> let n = List.length args and m = try Hashtbl.find const_hash c with Not_found -> Stdlib.max_int in if n < m then Hashtbl.replace const_hash c n | _ -> () end; List.iter add_consts_to_hash args end | Quant(_, (_, _, body)) -> add_consts_to_hash body | Equal(x, y) -> add_consts_to_hash x; add_consts_to_hash y | _ -> failwith "not FOL" let rec prune_pred_hash tm = assert (is_fol tm); match tm with | Const(c) -> Hashtbl.replace pred_hash c (-1) | Equal(x, y) -> prune_pred_hash x; prune_pred_hash y | App(_) when opt_multiple_arity_optimization -> let (x, args) = flatten_app tm in begin match x with | Const(c) -> let n = List.length args in assert (n > 0); Hashtbl.replace pred_hash (c ^ "_$a" ^ string_of_int n) (-1) | _ -> () end; List.iter prune_pred_hash args | App(x, y) -> prune_pred_hash x; prune_pred_hash y | Var(_) -> () | _ -> print_coqterm tm; failwith "prune_pred_hash" let rec build_pred_hash tm = assert (is_fol tm); match tm with | Quant(_, (_, ty, body)) -> assert (ty = type_any); build_pred_hash body | App(App(Const(c), x), y) when is_bin_logop c -> build_pred_hash x; build_pred_hash y | App(Const("~"), x) -> build_pred_hash x | App(_) -> let (x, args) = flatten_app tm in begin match x with | Const(c) when c <> "$HasType" -> let n = List.length args in assert (n > 0); if opt_multiple_arity_optimization then begin let c2 = c ^ "_$a" ^ string_of_int n in if not (Hashtbl.mem pred_hash c2) then Hashtbl.replace pred_hash c2 n end else let m = try Hashtbl.find pred_hash c with Not_found -> Hashtbl.add pred_hash c n; n in if n <> m then Hashtbl.replace pred_hash c (-1) | _ -> () end; List.iter prune_pred_hash args | Const(c) -> begin try let n = Hashtbl.find pred_hash c in if n <> 0 && not opt_multiple_arity_optimization then Hashtbl.replace pred_hash c (-1) with Not_found -> Hashtbl.add pred_hash c 0 end | _ -> prune_pred_hash tm let rec build_mconst_hash tm = match tm with | Var(_) | Const(_) -> () | App(_) -> begin let (x, args) = flatten_app tm in begin match x with | Const(c) when not (is_logop c) && c <> "$HasType" -> let n = List.length args in Hashtbl.replace mconst_hash (c ^ "_$a" ^ string_of_int n) (n, c) | _ -> () end; List.iter build_mconst_hash args end | Quant(_, (_, _, body)) -> build_mconst_hash body | Equal(x, y) -> build_mconst_hash x; build_mconst_hash y | _ -> failwith "not FOL" let rec build_tconst_hash tm = match tm with | Var(_) | Const(_) -> () | App(App(Const("$HasType"), _), ty) -> begin let (x, args) = flatten_app ty in begin match x with | Const(c) -> Hashtbl.replace tconst_hash c (List.length args) | _ -> () end end | App(App(Const(c), x), y) when is_bin_logop c -> build_tconst_hash x; build_tconst_hash y | App(Const("~"), x) -> build_tconst_hash x | Quant(_, (_, _, body)) -> build_tconst_hash body | App(_, _) | Equal(_, _) -> () | _ -> failwith "not FOL" (******************************************************************************) (* Escaping *) (* Escape characters not accepted by the TPTP format. *) let escape_to_hex s = let n = ref 0 in for i = 0 to String.length s - 1 do n := !n + (match String.unsafe_get s i with 'a'|'b'|'c'|'d'|'e'|'f'|'g'|'h'|'i'|'j'|'k'|'l'|'m'|'n'|'o'|'p'|'q'|'r'|'s'|'t'|'u'|'v'|'w'|'x'|'y'|'z' |'A'|'B'|'C'|'D'|'E'|'F'|'G'|'H'|'I'|'J'|'K'|'L'|'M'|'N'|'O'|'P'|'Q'|'R'|'S'|'T'|'U'|'V'|'W'|'X'|'Y'|'Z' |'0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9' -> 1 |'_' -> 2 | _ -> 3) done; if !n = String.length s then s else begin let s' = Bytes.create !n in n := 0; for i = 0 to String.length s - 1 do begin match String.unsafe_get s i with ('a'|'b'|'c'|'d'|'e'|'f'|'g'|'h'|'i'|'j'|'k'|'l'|'m'|'n'|'o'|'p'|'q'|'r'|'s'|'t'|'u'|'v'|'w'|'x'|'y'|'z' |'A'|'B'|'C'|'D'|'E'|'F'|'G'|'H'|'I'|'J'|'K'|'L'|'M'|'N'|'O'|'P'|'Q'|'R'|'S'|'T'|'U'|'V'|'W'|'X'|'Y'|'Z' |'0'|'1'|'2'|'3'|'4'|'5'|'6'|'7'|'8'|'9' as c) -> Bytes.unsafe_set s' !n c | '_' -> Bytes.unsafe_set s' !n '_'; incr n; Bytes.unsafe_set s' !n '_' | c -> let c = Char.code c in Bytes.unsafe_set s' !n '_'; incr n; Bytes.unsafe_set s' !n (Printf.sprintf "%x" (c / 16)).[0]; incr n; Bytes.unsafe_set s' !n (Printf.sprintf "%x" (c mod 16)).[0] end; incr n; done; Bytes.to_string s' end let is_primed name = name.[0] = '\'' && name.[String.length name - 1] = '\'' let add_prime s = if is_primed s then s else "\'" ^ s ^ "\'" let escape_special_thm s = Str.global_replace (Str.regexp_string "'") "\\'" (Str.global_replace (Str.regexp_string "\\") "\\\\" s) let escape_var s = "V" ^ escape_to_hex s let escape_const s = "c" ^ escape_to_hex s let escape_thm s = if (s.[0] = '\'') then s else add_prime (escape_special_thm s) (******************************************************************************) (* Writing *) let rec write_fol_rapp out write f args = match args with | [] -> f () | h :: t -> out "happ("; write_fol_rapp out write f t; out ","; write h; out ")" let write_fol_app out write f args = write_fol_rapp out write f (List.rev args) let rec write_fol_term out tm = match tm with | Const(c) -> out (escape_const c) | Var(v) -> out (escape_var v) | Equal(x, y) -> out (escape_const "="); out "("; write_fol_term out x; out ", "; write_fol_term out y; out ")" | App(_) -> let (x, args) = flatten_app tm in begin match x with | Const(c) -> if opt_multiple_arity_optimization || (opt_hastype && Hashtbl.mem tconst_hash c && Hashtbl.find tconst_hash c = List.length args) then write_fol_appterm out (c ^ "_$a" ^ string_of_int (List.length args)) args else let n = if opt_arity_optimization then Hashtbl.find const_hash c else 0 in assert (n <= List.length args); write_fol_papp out c n args | Var(_) -> write_fol_app out (write_fol_term out) (fun () -> write_fol_term out x) args | _ -> print_newline (); print_coqterm x; print_coqterm tm; failwith "write_fol_term (2)" end | _ -> print_newline (); print_coqterm tm; failwith "write_fol_term" and write_fol_appterm out c args = out (escape_const c); match args with | [] -> () | _ -> out "("; oiter out (write_fol_term out) "," args; out ")" and write_fol_papp out c n args = write_fol_app out (write_fol_term out) begin fun () -> write_fol_appterm out c (Hhlib.take n args) end (Hhlib.drop n args) let rec write_fol_formula out tm = assert (is_fol tm); match tm with | Quant(op, (vname, ty, body)) -> assert (ty = type_any); let (body2, vars) = flatten_fol_quant op tm in out op; out "["; oiter out out "," (List.map escape_var vars); out "]:"; write_fol_formula out body2 | Equal(x, y) -> out "("; write_fol_term out x; out " = "; write_fol_term out y; out ")" | App(App(Const(c), x), y) when is_bin_logop c -> out "("; write_fol_formula out x; out " "; out c; out " "; write_fol_formula out y; out ")" | App(Const("~"), x) -> out "~ ("; write_fol_formula out x; out ")" | App(App(Const("$HasType"), y), ty) -> let (x, args) = flatten_app ty in begin match x with | Const(c) when Hashtbl.find tconst_hash c = List.length args -> write_fol_appterm out (c ^ "_$t") (args @ [y]) | _ -> out "t("; write_fol_term out y; out ", "; write_fol_term out ty; out ")" end | App(_) when opt_predicate_optimization -> let (x, args) = flatten_app tm in begin match x with | Const(c) -> if opt_multiple_arity_optimization then begin let n = List.length args in let c2 = (c ^ "_$a" ^ string_of_int n) in if Hashtbl.find pred_hash c2 <> (-1) then write_fol_appterm out c2 args else begin out "p("; write_fol_term out tm; out ")" end end else begin let n = Hashtbl.find pred_hash c in if n >= 0 then begin assert (n = List.length args); write_fol_appterm out c args end else begin out "p("; write_fol_term out tm; out ")" end end | _ -> out "p("; write_fol_term out tm; out ")" end | _ -> out "p("; write_fol_term out tm; out ")" let write_fol what out (name, formula) = out "fof("; out (escape_thm name); out ", "; out what; out ", "; write_fol_formula out formula; out ").\n" let write_mult_arity_axioms out = let do_write k v n m = let rec hlp lst n = if n = 0 then begin let lst2 = List.map escape_var lst and args = List.map (fun name -> Var(name)) lst in out "!["; oiter out out "," lst2; out "]:("; if opt_predicate_optimization && Hashtbl.find pred_hash k <> (-1) then begin out "p("; write_fol_papp out v m args; out ") <=> "; write_fol_appterm out k args end else begin write_fol_papp out v m args; out " = "; write_fol_appterm out k args end; out ")" end else let vname = "$X" ^ string_of_int n in hlp (vname :: lst) (n - 1) in out "fof("; out (escape_thm ("$adef_" ^ k)); out ", axiom, "; hlp [] n; out ").\n" in Hashtbl.iter begin fun k (n, v) -> if opt_always_zero_arity && not (Hashtbl.mem tconst_hash v) then do_write k v n 0 else let m = Hashtbl.find const_hash v in if n <> m then do_write k v n m end mconst_hash let write_type_axioms out = let rec hlp c lst n = if n = 0 then begin let lst2 = List.map escape_var lst and args = List.map (fun name -> Var(name)) lst and v = escape_var "$Y" in let k = List.length args in let c2 = if k = 0 then c else if opt_multiple_arity_optimization then c ^ "_$a" ^ string_of_int k else c in out "!["; oiter out out "," (lst2 @ [v]); out "]:("; write_fol_appterm out (c ^ "_$t") (args @ [Var("$Y")]); out " <=> "; out "t("; out v; out ", "; write_fol_appterm out c2 args; out "))" end else let vname = "$X" ^ string_of_int n in hlp c (vname :: lst) (n - 1) in Hashtbl.iter begin fun c n -> out "fof("; out (escape_thm ("$tdef_" ^ c)); out ", axiom, "; hlp c [] n; out ").\n" end tconst_hash let write_fol_problem out axioms thm = log 1 ("write_fol_problem: " ^ fst thm); Hashtbl.clear tconst_hash; Hashtbl.clear mconst_hash; Hashtbl.clear const_hash; Hashtbl.clear pred_hash; if opt_hastype then begin List.iter build_tconst_hash (List.map snd axioms); build_tconst_hash (snd thm) end; if opt_multiple_arity_optimization then begin List.iter build_mconst_hash (List.map snd axioms); build_mconst_hash (snd thm) end; if opt_arity_optimization || opt_multiple_arity_optimization then begin List.iter add_consts_to_hash (List.map snd axioms); add_consts_to_hash (snd thm) end; if opt_predicate_optimization then begin List.iter build_pred_hash (List.map snd axioms); build_pred_hash (snd thm) end; List.iter (write_fol "axiom" out) axioms; if opt_multiple_arity_optimization then begin write_mult_arity_axioms out end; if opt_hastype then begin write_type_axioms out end; write_fol "conjecture" out thm; Hashtbl.clear tconst_hash; Hashtbl.clear mconst_hash; Hashtbl.clear const_hash; Hashtbl.clear pred_hash coqhammer-1.3.2-8.20/src/plugin/tptp_out.mli000066400000000000000000000003501471571225200205300ustar00rootroot00000000000000open Coqterms (* write an already translated problem to FOF TPTP format *) val write_fol_problem : (string -> unit) (* output function *) -> fol_axioms (* axioms *) -> (string (* name *) * fol (* formula *)) (* goal *) -> unit coqhammer-1.3.2-8.20/src/predict/000077500000000000000000000000001471571225200163055ustar00rootroot00000000000000coqhammer-1.3.2-8.20/src/predict/dtree.cpp000066400000000000000000000124311471571225200201150ustar00rootroot00000000000000#ifndef DTREE_CPP #define DTREE_CPP #include #include typedef unordered_map LUMap; class DecisionTree { public: // trees which have (left) and which do not have (right) feature DecisionTree *left = NULL, *right = NULL; long feature = -1; LVec labels; LUMap features_freq; long n_samples = 0; DecisionTree(LVec labels = LVec()) : labels(labels) {} DecisionTree(DecisionTree *left, DecisionTree *right, long feature) : left(left), right(right), feature(feature) {} DecisionTree(string filename, const SLMap& th_no, const SLMap& sym_no); ~DecisionTree() { delete left; delete right; } bool is_leaf() const { return (left == NULL) || (right == NULL); } long height() const { if (is_leaf()) return 1; else return 1 + max(left->height(), right->height()); } void add_labels_recursively(LVec& result) const; void query(const LVec& features, LDMap& result, double weight) const; void write_to_file(string filename, const SVec& no_th, const SVec& no_sym) const; private: string dot(string pos, const SVec& no_th, const SVec& no_sym) const; const double punish_weight = 0.05; const double min_weight = punish_weight*punish_weight; }; void DecisionTree::add_labels_recursively(LVec& result) const { if (is_leaf()) result.insert(result.end(), labels.begin(), labels.end()); else { left ->add_labels_recursively(result); right->add_labels_recursively(result); } } void DecisionTree::query(const LVec& features, LDMap& result, double weight = 1.0) const { if (weight < min_weight) return; if (is_leaf()) for (const auto& l : labels) result[l] += weight; else { double lweight = weight, rweight = weight; LVec::const_iterator fitr = find(features.begin(), features.end(), feature); if (fitr == features.end()) lweight *= punish_weight; else rweight *= punish_weight; left->query(features, result, lweight); right->query(features, result, rweight); } } DecisionTree::DecisionTree(string filename, const SLMap& th_no, const SLMap& sym_no) : DecisionTree() { ifstream f(filename); if (f.is_open()) { string line; while (getline(f, line)) { if (line.find("->") != string::npos || line == "digraph tree {" || line == " node [shape=box]" || line == "}") continue; else { DecisionTree *pos = this; bool is_feature = true; auto p = find_if_not(line.begin(), line.end(), [](char c) { return c == ' '; } ); if (p == line.end() || *p != 't') exit_error("Tree position expected!"); p++; while (p != line.end()) { if (*p == ' ') break; switch (*p) { case 'l': if (pos->left == NULL) pos->left = new DecisionTree; pos = pos->left; break; case 'r': if (pos->right == NULL) pos->right = new DecisionTree; pos = pos->right; break; default: if (isdigit(*p)) is_feature = false; else exit_error("Unknown character in tree position found."); } p++; } if (*p != ' ') exit_error("Content expected after tree position."); auto opening_quote = find(p + 1, line.end(), '"'); if (opening_quote == line.end()) exit_error("Opening quote not found."); auto closing_quote = find(opening_quote + 1, line.end(), '"'); if (closing_quote == line.end()) exit_error("Closing quote not found."); string name_str(opening_quote + 1, closing_quote); if (is_feature) { auto sym = sym_no.find(name_str); if (sym == sym_no.end()) exit_error("Could not find feature `" + name_str + "'"); else pos->feature = sym->second; } else { auto th = th_no.find(name_str); if (th == th_no.end()) exit_error("Could not find label `" + name_str + "'"); else pos->labels.push_back(th->second); } } } f.close(); } else exit_error("Could not read file `" + filename + "'."); } void DecisionTree::write_to_file(string filename, const SVec& no_th, const SVec& no_sym) const { string s = "digraph tree {\n" " node [shape=box]\n" + dot("t", no_th, no_sym) + "}\n"; ofstream f(filename); if (f.is_open()) { f << s; f.close(); } else cerr << "Could not write file `" << filename << "'.\n"; } string DecisionTree::dot(string pos, const SVec& no_th, const SVec& no_sym) const { string s; if (is_leaf()) { for (unsigned i = 0; i < labels.size(); i++) { string new_pos = pos + to_string(i); s += " " + pos + " -> " + new_pos + "\n"; s += " " + new_pos + " [label = \"" + no_th[labels[i]] + "\" shape = ellipse]\n"; } } else { s += " " + pos + " [label = \"" + no_sym[feature] + "\"]\n"; s += " " + pos + " -> " + pos + "l\n"; s += " " + pos + " -> " + pos + "r\n"; s += left->dot(pos + "l", no_th, no_sym); s += right->dot(pos + "r", no_th, no_sym); } return s; } #endif coqhammer-1.3.2-8.20/src/predict/format.cpp000066400000000000000000000114151471571225200203030ustar00rootroot00000000000000#ifndef FORMAT_CPP #define FORMAT_CPP #include #include #include #include #include #include using namespace std; typedef unordered_map SLMap; typedef vector SVec; typedef vector LVec; typedef vector > LVecVec; typedef vector > LDPairVec; typedef unordered_map LDMap; void exit_error(string message) { cerr << message << endl; exit(1); } /* Given a file name, fills the given empty [th_no], [no_th], and sets th_num */ void read_order(const string &fname, SLMap &th_no, SVec &no_th) { ifstream ic(fname); string line; while (getline (ic, line)) { if (th_no.find (line) == th_no.end ()) { th_no[line] = no_th.size(); no_th.push_back(line); } else exit_error("Duplicate `" + line + "' detected upon reading file `" + fname + "."); } } /* Given a file name and trans, fills deps in an allocated vector of empty vectors */ void read_deps(const string &fname, SLMap &th_no, LVecVec &deps) { ifstream ic(fname); string line; while (getline (ic, line)) { const long colon_pos = line.find(":", 0); const string thn = line.substr (0, colon_pos); if (th_no.find (thn) == th_no.end ()) cerr << "dep item missing in seq: " << thn << endl; else { long th = th_no[thn]; size_t start = colon_pos + 1, end = 0; const string delim = " "; if (line.size() > start) while (end != string::npos) { end = line.find(delim, start); auto t = line.substr(start, (end == string::npos) ? string::npos : end - start); start = ((end > (string::npos - delim.size())) ? string::npos : end + delim.size()); if (th_no.find (t) == th_no.end ()) cerr << "dependency missing in seq: " << t << endl; else { long d=th_no[t]; #ifdef COQ_MODE deps[th].push_back(d); #else if (d < th) deps[th].push_back(d); else cerr << "future dep (ignored): " << thn << "(" << th << ") " << t << "(" << d << ")" << endl; #endif } } } } } // parses strings of the format: // "string1", "string2", ..., "stringn" SVec parse_string_list(string::iterator begin, string::iterator end) { SVec result; while (true) { if (begin == end || *begin != '"') exit_error("Feature start with double quote expected!"); const auto closing_quote = find(begin + 1, end, '"'); if (closing_quote == end) exit_error("Features stop with double quote expected!"); result.push_back(string(begin + 1, closing_quote)); const auto comma = closing_quote + 1; if (comma == end) break; else { const auto space = comma + 1; if (space == end) exit_error("Space expected after comma!"); else if (*comma != ',' || *space != ' ') exit_error("Comma and space expected after feature!"); begin = space + 1; } } return result; } // parses strings of the format: // thmid:"feature1", "feature2", ..., "featuren" void read_syms(const string &fname, LVecVec &syms, LVecVec &sym_ths, long &sym_num, const SLMap &th_no, SLMap &sym_no, SVec& no_sym) { ifstream ic(fname); string line; while (getline(ic, line)) { const auto colon = find(line.begin(), line.end(), ':'); if (colon == line.end()) exit_error("Expected colon in line `" + line + "'!"); string th_str(line.begin(), colon); auto th_got = th_no.find(th_str); if (th_got == th_no.end()) exit_error("Theorem `" + th_str + "' not found!"); long th = th_got->second; SVec features = parse_string_list(colon + 1, line.end()); for (const auto& f : features) { auto ftr_got = sym_no.find(f); if (ftr_got == sym_no.end()) { syms[th].push_back(sym_num); sym_ths.push_back(vector(1,th)); // register new feature sym_no[f] = sym_num++; no_sym.push_back(f); } else { syms[th].push_back(ftr_got->second); sym_ths[ftr_got->second].push_back(th); } } } } LVec parse_feature_list(string::iterator begin, string::iterator end, const SLMap& ftr_no) { LVec result; for (const auto& f : parse_string_list(begin, end)) { auto got = ftr_no.find(f); if (got != ftr_no.end()) result.push_back(got->second); } return result; } void read_eval(const string &fname, unordered_map &th_no, unordered_set &eval) { ifstream ic(fname); string line; while (getline(ic, line)) { auto get = th_no.find (line); if (get == th_no.end()) exit_error("Could not find theorem `" + line + "' in file `" + fname + "'."); else eval.insert(get->second); } } #endif coqhammer-1.3.2-8.20/src/predict/knn.cpp000066400000000000000000000056231471571225200176050ustar00rootroot00000000000000#include #include "predictor.cpp" class kNN : public Predictor { public: kNN(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num); void learn(long from, long to); protected: LDPairVec predict(const LVec& csyms, long maxth, long no_adv) const; private: Tfidf tfidf; }; kNN::kNN(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num) : Predictor(deps, syms, sym_ths, sym_num), tfidf(sym_num) { } void kNN::learn(long from, long to) { for (long i = from; i < to; ++i) tfidf.add(syms[i]); } inline double age(long k) { return 500000000 - 100 * k; } LDPairVec kNN::predict(const LVec& csyms, long maxth, long no_adv) const { LDPairVec ans = LDPairVec(maxth, make_pair(0, 0)); // initialise theorem importance matrix for (long i = 0; i < maxth; ++i) { ans[i].first = i; ans[i].second = 0; } // for each symbol, increase the importance of the theorems which contain // the symbol by a given symbol weight for (const auto& sym : csyms) { vector ths = sym_ths[sym]; double weight = tfidf.get(sym); for (const auto& th : ths) { if (th < maxth) ans[th].second += pow(weight, 6); } } LDPairVec neighbours(maxth); partial_sort_copy(ans.begin(), ans.end(), neighbours.begin(), neighbours.end(), sortfun); for (auto& a : ans) a.second = 0; // In typical k-NN implementation the number 'k' is fixed. Unfortunately for // premise selection, using a wrong number may have quite bad implications, // namely the neighbours may all be very similar and have very similiar dependencies. // This may mean that we will not have enough non-zero entries to fill no-adv predictions. // This is why we use an adaptive 'k'. We count how many premises we recommended, // and we continue until this number is enough. // Since we want to sort the list of recommended answers only once, we want to make // sure that items recommended by a certain 'k' are before those coming for the increased // k. In order to do this, we use an "age" that is added to non-zero predictions // and decreases when k increases. long no_recommends = 0; for (long k = 0; k < maxth && no_recommends < no_adv; ++k) { long nn = neighbours[k].first; double o = neighbours[k].second; // distance, we do not use sqrt if (ans[nn].second <= 0) { no_recommends++; ans[nn].second = age(k) + o; } else ans[nn].second += o; // dependencies of the neighbor also gain some relevance, depending on the // number of dependencies of the current theorem LVec ds = deps[nn]; double ol = 2.7 * o / ds.size(); for (const auto& d : ds) { if (d < maxth) { // in case of future dependencies, do not predict them if (ans[d].second <= 0) { no_recommends++; ans[d].second = age(k) + ol; } else ans[d].second += ol; } } } sort_prediction(ans, no_adv); return ans; } coqhammer-1.3.2-8.20/src/predict/main.cpp000066400000000000000000000143671471571225200177500ustar00rootroot00000000000000#include #include #include "knn.cpp" #include "mepo.cpp" #include "nbayes.cpp" #include "rforest.cpp" const string usage_str = "Usage: predict [OPTION]...\n" "\n" "Mandatory arguments:\n" " is a file containing the symbols of theorems\n" " is a file containing the dependencies of theorems\n" " is a file containing the order of theorems\n" "\n" "General options:\n" " -p method is either knn, mepo, nbayes, or rforest\n" " -n i is the number of predictions to output\n" " -e eval is an optional file, containing theorems for which we want predictions\n" " -x eXport learned predictor data to path\n" " -y Ymport learned predictor data from path\n" "\n" "Predictor-specific options:\n" " Random Forest:\n" " -t number of trees to build\n" " -s number of samples to consider per tree\n" " -f number of features to consider per tree\n" " -w dependency weight\n" #ifdef COQ_MODE "\n" "Predictor compiled in Coq mode.\n"; #else ""; #endif void print_prediction(LDPairVec prediction, long n_predictions, vector no_th) { for (long j = 0; j < n_predictions; ++j) { // print label cout << no_th[prediction[j].first] << " "; // print weight //cout << "(" << prediction[j].second << ") "; } cout << endl; } void interaction(unique_ptr& p, long predno, const SLMap& sym_no, const vector& no_th) { p->learn_all(); cerr << "Learning done; awaiting your features ..." << endl; string line; while (getline(cin, line)) { const LVec symsi = parse_feature_list(line.begin(), line.end(), sym_no); long no_adv = min((long)no_th.size(), predno); const LDPairVec ans = p->predict(symsi, no_th.size(), no_adv); print_prediction(ans, no_adv, no_th); } } void evaluation(unique_ptr& p, string evalf, long predno, SLMap th_no, vector no_th) { unordered_set eval; read_eval(evalf, th_no, eval); // last theorem up to which we learnt long prev = 0; for (long i = 0; i < (long)no_th.size(); ++i) { if (eval.find(i) != eval.end()) { p->learn(prev, i); prev = i; long no_adv = min(i, predno); LDPairVec ans = p->predict(i, i, no_adv); cout << no_th[i] << ":"; print_prediction(ans, no_adv, no_th); } } } int atoi_check(const char *nptr, const char *desc) { int result = atoi(nptr); if (result == 0) { cerr << "Error: You have to specify a valid " << desc << "!\n"; exit(EXIT_FAILURE); } else return result; } double atof_check(const char *nptr, const char *desc) { double result = atof(nptr); if (result == 0.0) { cerr << "Error: You have to specify a valid " << desc << "!\n"; exit(EXIT_FAILURE); } else return result; } int main(int argc, char* argv[]) { const int MIN_ARGS = 3; if (argc < MIN_ARGS + 1) { cerr << usage_str; return EXIT_FAILURE; } // obligatory files string symsf(argv[1]), depsf(argv[2]), seqf(argv[3]); // evaluation file string evalf = ""; // number of predictions to output long predno = 1000; // prediction method string method = "knn"; // path to prelearned predictor data string import_path, export_path; // Random Forest specific options long n_trees = 512; long n_samples = 512; long n_features = 128; double depweight = 1.7; char c; optind = MIN_ARGS + 1; // start getopt after obligatory arguments while ((c = getopt (argc, argv, "he:n:p:k:t:s:f:w:x:y:")) != -1) switch (c) { case 'h': cout << usage_str; return EXIT_SUCCESS; case 'e': evalf = optarg; break; case 'n': predno = atoi_check(optarg, "number of predictions"); break; case 'p': method = optarg; break; case 'x': export_path = optarg; break; case 'y': import_path = optarg; break; case 't': n_trees = atoi_check(optarg, "number of trees"); break; case 's': n_samples = atoi_check(optarg, "number of samples per tree"); break; case 'f': n_features = atoi_check(optarg, "number of features per tree"); break; case 'w': depweight = atof_check(optarg, "dependency weight"); break; case '?': // unknown option or option lacking an argument // getopt prints an error message (unless opterr is set to 0) cerr << "Try '" << argv[0] << " -h' for more information.\n"; return EXIT_FAILURE; } long sym_num = 0; SLMap th_no, // maps a theorem to its numeric identifier sym_no; // maps a symbol to its numeric identifier vector no_th, // theorem name table no_sym; LVecVec deps, // dependencies of each theorem syms, // syms[t] holds the symbols of a theorem t sym_ths; // sym_ths[s] holds the theorems which contain s read_order(seqf, th_no, no_th); deps = LVecVec(no_th.size(), vector(0)); syms = LVecVec(no_th.size(), vector(0)); read_deps(depsf, th_no, deps); read_syms(symsf, syms, sym_ths, sym_num, th_no, sym_no, no_sym); // getting number of a theorem //cout << th_no["Set.subsetI"] << endl; // initialise predictor unique_ptr predictor; if (method == "knn") predictor.reset(new kNN(deps, syms, sym_ths, sym_num)); else if (method == "mepo") predictor.reset(new MePo(deps, syms, sym_ths, sym_num)); else if (method == "nbayes") predictor.reset(new NaiveBayes(deps, syms, sym_ths, sym_num)); else if (method == "rforest") predictor.reset(new RandomForest(deps, syms, sym_ths, sym_num, n_trees, n_samples, n_features, depweight)); else { cerr << "Error: You have to specify a valid predictor!\n"; return EXIT_FAILURE; } predictor->set_tables(no_th, no_sym, th_no, sym_no); if (!import_path.empty()) predictor->import_data(import_path); // if user did not supply evaluation file if (evalf == "") interaction(predictor, predno, sym_no, no_th); else evaluation(predictor, evalf, predno, th_no, no_th); if (!export_path.empty()) predictor->export_data(export_path); } coqhammer-1.3.2-8.20/src/predict/mepo.cpp000066400000000000000000000043261471571225200177560ustar00rootroot00000000000000#include #include "predictor.cpp" inline double sq(const double& x) { return x * x; } double cosine(const LDMap &syms1, const LVec &syms2, const Tfidf &tfidf){ double sig = 0, sig1 = 0, sig2 = 0; for (auto s : syms1) sig1 += sq(tfidf.get(s.first)) * sq(s.second); for (auto s : syms2) { const double tw = tfidf.get(s); sig2 += sq(tw); auto got = syms1.find(s); if (got != syms1.end()) sig += sq(tw) * got->second; } return (sq(sig) / (sig1 * sig2)); // for jaccard use: // return (sig / (sig1 + sig2 + sig)); } double euclid(const LDMap &syms1, const LVec &syms2, const Tfidf &tfidf) { double sig = 0; for (auto s : syms2) if (syms1.find(s) == syms1.end()) sig += sq(tfidf.get(s)); for (const auto& s : syms1) if (find(syms2.begin(), syms2.end(), s.first) == syms2.end()) sig += sq(tfidf.get(s.first)) * sq(s.second); return (1 / (1 + sig)); } class MePo : public Predictor { public: MePo(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num); void learn(long from, long to); protected: LDPairVec predict(const LVec& csyms, long maxth, long no_adv) const; private: Tfidf tfidf; const static int mepo_incr = 100; }; MePo::MePo(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num) : Predictor(deps, syms, sym_ths, sym_num), tfidf(sym_num) { } void MePo::learn(long from, long to) { for (long i = from; i < to; ++i) tfidf.add(syms[i]); } LDPairVec MePo::predict(const LVec& csyms, long maxth, long no_adv) const { // theorem importance matrix LDPairVec ans = LDPairVec(maxth, make_pair(0, 0)); for (long i = 0; i < maxth; ++i) ans[i].first = i; LDMap nsyms; for (auto s : csyms) nsyms[s] = 1.0; for (long sofar = 0; sofar < no_adv; sofar += mepo_incr) { for (long i = sofar; i < maxth; ++i) ans[i].second = cosine(nsyms, syms[ans[i].first], tfidf); long until = min(sofar + mepo_incr, no_adv); partial_sort(ans.begin() + sofar, ans.begin() + until, ans.begin() + maxth, sortfun); if (until >= maxth) return ans; for (long i = sofar; i < until; i++) for (auto s : syms[ans[i].first]) nsyms[s] = max(nsyms[s], ans[i].second); } return ans; } coqhammer-1.3.2-8.20/src/predict/nbayes.cpp000066400000000000000000000055511471571225200203000ustar00rootroot00000000000000#include #include #include #include "predictor.cpp" typedef long feature_t; typedef long sample_t; class NaiveBayes : public Predictor { public: NaiveBayes(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num); void learn(long from, long to); LDPairVec predict(const LVec& csyms, long maxth, long no_adv) const; private: double score(sample_t i, set symsh) const; void learn(const LVec& csyms, sample_t i, const LVec& cdeps); void add_sample_freqs(const LVec& csyms, sample_t i, long weight); // tfreq[t] = number of theorems having t as dependency vector tfreq; // sfreq[t][f] = number of theorems having f and having t as dependency vector > sfreq; Tfidf tfidf; }; NaiveBayes::NaiveBayes(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num) : Predictor(deps, syms, sym_ths, sym_num), tfidf(sym_num) { tfreq.resize(deps.size()); sfreq.resize(deps.size(), unordered_map (100)); } void NaiveBayes::learn(sample_t from, sample_t to) { for (sample_t i = from; i < to; ++i) tfidf.add(syms[i]); for (sample_t i = from; i < to; i++) learn(syms[i], i, deps[i]); } LDPairVec NaiveBayes::predict(const LVec &csyms, sample_t maxth, long no_adv) const { LDPairVec ans = LDPairVec(maxth, make_pair(0, 0)); // set of query features set symh(csyms.begin(), csyms.end()); for(long i = 0; i < maxth; ++i) { ans[i].first = i; ans[i].second = score(i, symh); } sort_prediction(ans, no_adv); return ans; } double NaiveBayes::score(sample_t i, set symh) const { // number of times current theorem was used as dependency const long n = tfreq[i]; const auto sfreqh = sfreq[i]; double s = 30 * log(n); for (const auto& sv : sfreqh) { // sv.first ranges over all features of theorems depending on i // sv.second is the number of times sv.first appears among theorems // depending on i double sfreqv = sv.second; // if sv.first exists in query features if (symh.erase(sv.first) == 1) s += tfidf.get(sv.first) * log (5 * sfreqv / n); else s += tfidf.get(sv.first) * 0.2 * log (1 + (1 - sfreqv) / n); } // for all query features that did not appear in features of dependencies // of current theorem for (const auto f : symh) s -= tfidf.get(f) * 18; return s; } void add_sym(unordered_map &m, feature_t sym, long w) { auto itr = m.find(sym); if (itr == m.end()) m[sym] = w; else (itr->second) += w; } void NaiveBayes::add_sample_freqs(const LVec& csyms, sample_t i, long w) { tfreq[i] += w; for (const auto s : csyms) add_sym(sfreq[i], s, w); } void NaiveBayes::learn(const LVec& csyms, sample_t i, const LVec& cdeps) { add_sample_freqs(csyms, i, 1000); for (const auto d : cdeps) add_sample_freqs(csyms, d, 1); } coqhammer-1.3.2-8.20/src/predict/predictor.cpp000066400000000000000000000035371471571225200210140ustar00rootroot00000000000000#ifndef PREDICTOR_CPP #define PREDICTOR_CPP #include #include "format.cpp" #include "tfidf.cpp" class Predictor { public: Predictor(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num); virtual ~Predictor() {} virtual void learn(long from, long to) = 0; // learn [from, ..., to) void learn_all(); LDPairVec predict(long i, long maxth, long no_adv); virtual LDPairVec predict(const LVec& csyms, long maxth, long no_adv) const = 0; void set_tables(SVec no_th, SVec no_sym, SLMap th_no, SLMap sym_no); virtual void import_data(string location) {} virtual void export_data(string location) const {} protected: LVecVec deps, // dependencies of each theorem syms, // syms[t] holds the symbols of a theorem t sym_ths; // sym_ths[s] holds the theorems which contain s SVec no_th, no_sym; SLMap th_no, sym_no; private: void print_answer(long no_adv); }; Predictor::Predictor(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num) : deps(deps), syms(syms), sym_ths(sym_ths) {} void Predictor::learn_all() { learn(0, syms.size() - 1); } LDPairVec Predictor::predict(long i, long maxth, long n_predictions) { return predict(syms[i], maxth, n_predictions); } void Predictor::set_tables(SVec no_th, SVec no_sym, SLMap th_no, SLMap sym_no) { this->no_th = no_th; this->no_sym = no_sym; this->th_no = th_no; this->sym_no = sym_no; } inline bool sortfun (pair i, pair j) { return (j.second < i.second); } // sort the theorem-probability table such that the first n_predictions // elements of it contain the best predictions void sort_prediction(LDPairVec& prediction, long n_predictions) { partial_sort(prediction.begin(), prediction.begin() + n_predictions, prediction.end(), sortfun); } #endif coqhammer-1.3.2-8.20/src/predict/rforest.cpp000066400000000000000000000275151471571225200205070ustar00rootroot00000000000000#ifndef RFOREST_CPP #define RFOREST_CPP #include #include "dtree.cpp" #include "predictor.cpp" #include "tfidf.cpp" class RandomForest : public Predictor { public: RandomForest(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num, long n_trees, long n_samples, long n_features, double depweight); ~RandomForest(); void import_data(string dirname); void export_data(string dirname) const; void learn(long from, long to); LDPairVec predict(const LVec& csyms, long maxth, long no_adv) const; private: long n_of_samples_with_label(const LVec& samples, long label) const; long n_of_labels_in_samples(const LVec& samples) const; pair labels_of_samples(const LVec& samples) const; double gini_part(const LVec& samples) const; double gini_index(const LVec& samples, long feature) const; LUMap features_frequency(const LVec& samples) const; long feature_minlabels(const LVec& samples, long feature) const; long best_feature_gini(const LVec& samples, unsigned min_labels, const LUMap& features_freq) const; long best_feature_naive(const LVec& samples) const; void update_tree(DecisionTree *tree, const LVec& samples); DecisionTree* grow_tree(const LVec& samples); DecisionTree* grow_tree(const LVec& samples, unsigned min_labels, const LUMap& features_freq); vector forest; long n_samples; // number of samples to consider per tree long n_features; // number of features to consider per tree double depweight; bool prelearned; Tfidf labels_ti; mt19937 rng; // random number generator, in this case Mersenne twister }; // TODO: seed hard-coded ... RandomForest::RandomForest(LVecVec deps, LVecVec syms, LVecVec sym_ths, long sym_num, long n_trees, long n_samples, long n_features, double depweight) : Predictor(deps, syms, sym_ths, sym_num), forest(n_trees, NULL), n_samples(n_samples), n_features(n_features), depweight(depweight), prelearned(false), labels_ti(deps.size()), rng(42) { for (auto& tree : forest) tree = new DecisionTree; } RandomForest::~RandomForest() { for (auto& tree : forest) delete tree; } void RandomForest::import_data(string dirname) { for (unsigned i = 0; i < forest.size(); i++) forest[i] = new DecisionTree(dirname + "/tree" + to_string(i) + ".dot", th_no, sym_no); prelearned = true; } void RandomForest::export_data(string dirname) const { for (unsigned i = 0; i < forest.size(); i++) forest[i]->write_to_file(dirname + "/tree" + to_string(i) + ".dot", no_th, no_sym); } void RandomForest::learn(long from, long to) { // update TF-IDF information for labels for (long i = from; i < to; i++) labels_ti.add(deps[i]); if (prelearned) return; // by how many trees will a sample be learnt const long sampling_frequency = 1; // determine which tree should learn which samples LVecVec tree_samples(forest.size()); uniform_int_distribution<> tree_distr(0, forest.size() - 1); for (long s = from; s < to; s++) for (long n = 0; n < sampling_frequency; n++) tree_samples[tree_distr(rng)].push_back(s); for (unsigned t = 0; t < forest.size(); t++) update_tree(forest[t], tree_samples[t]); /* // probability of sampling from the range [from, to), when we // draw from [0, to) double prob = (to - from) / double(to); binomial_distribution bin_dist(n_samples, prob); uniform_int_distribution uni_dist_old(0, from - 1); uniform_int_distribution uni_dist_new(from, to - 1); for (auto& tree : forest) { long n_new_samples = bin_dist(rng); // update tree if we need to consider new samples if (n_new_samples > 0) { LVec samples_old(n_samples - n_new_samples); LVec samples_new(n_new_samples); for (auto& sample : samples_old) sample = uni_dist_old(rng); for (auto& sample : samples_new) sample = uni_dist_new(rng); samples_new.insert(samples_new.end(), samples_old.begin(), samples_old.end()); // regrow delete tree; tree = grow_tree(samples_new); } } */ } LDPairVec RandomForest::predict(const LVec& csyms, long maxth, long no_adv) const { LDPairVec ans = LDPairVec(maxth, make_pair(0, 0)); for (long i = 0; i < maxth; ++i) { ans[i].first = i; ans[i].second = 0; } LDMap labels; for (const auto& tree : forest) tree->query(csyms, labels); /* double tfidf_d = 1; for (const auto& feature : positives) // is a low TF-IDF better or worse? // if low was better, we should probably divide here! tfidf_d *= tfidf.get(feature); long tfidf_l = tfidf_d * 1000.0; //cout << tfidf_l << endl; */ for (const auto& label : labels) { // this might be the case if we use a prelearned tree, and to prevent // suggesting theorems "from the future", we discard them if (label.first >= maxth) continue; ans[label.first].second += label.second; // / pow(labels_ti.get(label), 1); const LVec& ds = deps[label.first]; for (const auto& dep : ds) { //cerr << dw / pow(labels_ti.get(dep), 3) << endl; ans[dep].second += depweight * label.second; // / pow(labels_ti.get(dep), 4); } } sort_prediction(ans, no_adv); return ans; } long RandomForest::n_of_samples_with_label(const LVec& samples, long label) const { long sum = 0; for (const auto& sample : samples) { const LVec& ds = deps[sample]; if (sample == label || find(ds.begin(), ds.end(), label) != ds.end()) sum++; } return sum; } pair RandomForest::labels_of_samples(const LVec& samples) const { LUMap labels; long n_labels = 0; for (const auto& sample : samples) { labels[sample]++; n_labels++; for (const auto& dep : deps[sample]) { labels[dep]++; n_labels++; } } return make_pair(labels, n_labels); } double RandomForest::gini_part(const LVec& samples) const { auto l = labels_of_samples(samples); LUMap labels = l.first; double n_labels = l.second; double sum = 0.0; for (const auto& label : labels) { double p = n_of_samples_with_label(samples, label.first) / n_labels; sum += (p - p*p) * label.second; } return samples.size() * sum; } double RandomForest::gini_index(const LVec& samples, long feature) const { LVec yes, no; for (const auto& sample : samples) { const LVec& features = syms[sample]; if (find(features.begin(), features.end(), feature) != features.end()) yes.push_back(sample); else no.push_back(sample); } return gini_part(yes) + gini_part(no); } LUMap RandomForest::features_frequency(const LVec& samples) const { LUMap features_freq; for (const auto& sample : samples) for (const auto& feature : syms[sample]) features_freq[feature]++; return features_freq; } long RandomForest::feature_minlabels(const LVec& samples, long feature) const { LVec left, right; for (const auto& sample : samples) { const LVec& csyms = syms[sample]; if (find(csyms.begin(), csyms.end(), feature) != csyms.end()) left.push_back(sample); else right.push_back(sample); } return min(labels_of_samples(left ).second, labels_of_samples(right).second); } template Container sample_with_replacement(const Container& c, unsigned n, Generator& g) { // generate sorted vector of container indices vector indices(n); uniform_int_distribution<> distr(0, c.size() - 1); for (auto& i : indices) i = distr(g); sort(indices.begin(), indices.end()); Container result; auto citr = c.cbegin(); unsigned prev_i = 0; for (const auto& i : indices) { advance(citr, i - prev_i); prev_i = i; copy_n(citr, 1, inserter(result, result.end())); } return result; } long RandomForest::best_feature_gini(const LVec& samples, unsigned min_labels, const LUMap& features_freq) const { long best_f = -1; double best_gini = 0; // iterate through unique list of features for (const auto& f : features_freq) { // check if a feature even has a chance to provide a valid split if (feature_minlabels(samples, f.first) >= (long)min_labels) { double gini = gini_index(samples, f.first); if (gini < best_gini || best_f == -1) { best_f = f.first; best_gini = gini; } } } return best_f; } long RandomForest::best_feature_naive(const LVec& samples) const { LUMap ff = features_frequency(samples); long optimal_n_samples = samples.size() / 2; long best_f = -1; long best_diff = 0; for (const auto& f : ff) { long diff = abs((long)(f.second - optimal_n_samples)); if (diff < best_diff || best_f == -1) { best_f = f.first; best_diff = diff; } } return best_f; } void RandomForest::update_tree(DecisionTree *tree, const LVec& new_samples) { if (new_samples.empty()) return; for (const auto& sample : new_samples) for (const auto& feature : syms[sample]) tree->features_freq[feature]++; tree->n_samples += new_samples.size(); long optimal_n_samples = tree->n_samples / 2; long best_f = -1; long best_diff = 0; // we have to consider all features present in the tree at this point, // because it might be that a feature that was previously bad, now has // become a good splitting feature, even if it did not appear at all // in the new samples for (const auto& f : tree->features_freq) { long diff = abs((long)(f.second - optimal_n_samples)); if (diff < best_diff || best_f == -1) { best_f = f.first; best_diff = diff; } } LVec update_samples = new_samples; if (best_f != tree->feature) { tree->add_labels_recursively(update_samples); delete tree->left; delete tree->right; tree->left = new DecisionTree; tree->right = new DecisionTree; } const LVec& best = sym_ths[best_f]; LVec left, right; // divide samples into those which have the best feature and those who do not for (const auto& sample : update_samples) if (find(best.begin(), best.end(), sample) != best.end()) left.push_back(sample); else right.push_back(sample); if (min(left .size() + tree->left ->n_samples, right.size() + tree->right->n_samples) < 1) { tree->labels = update_samples; tree->feature = -1; delete tree->left; delete tree->right; tree->left = NULL; tree->right = NULL; } else { tree->labels = LVec(); tree->feature = best_f; update_tree(tree->left , left); update_tree(tree->right, right); } } DecisionTree* RandomForest::grow_tree(const LVec& samples) { LUMap ff = features_frequency(samples); // remove too seldomly occuring features /*for (auto fi = ff.begin(); fi != ff.end(); ) if (fi->second <= 3) fi = ff.erase(fi); else fi++;*/ LUMap fs = sample_with_replacement(ff, n_features, rng); return grow_tree(samples, 1/*2*log(labels_of_samples(samples).second)*/, fs); } DecisionTree* RandomForest::grow_tree(const LVec& samples, unsigned min_labels, const LUMap& features_freq) { long best_f = best_feature_naive(samples); //long best_f = best_feature_gini(samples, min_labels, features_freq); if (best_f == -1) return new DecisionTree(samples); const LVec& best = sym_ths[best_f]; LVec left, right; // divide samples into those which have the best feature and those who do not for (const auto& sample : samples) if (find(best.begin(), best.end(), sample) != best.end()) left.push_back(sample); else right.push_back(sample); // stop growing tree if one of its children would be too small if (min(labels_of_samples(left ).second, labels_of_samples(right).second) < (long)min_labels) return new DecisionTree(samples); else { DecisionTree *t_left = grow_tree(left , min_labels, features_freq); DecisionTree *t_right = grow_tree(right, min_labels, features_freq); return new DecisionTree(t_left, t_right, best_f); } } #endif coqhammer-1.3.2-8.20/src/predict/tfidf.cpp000066400000000000000000000024431471571225200201100ustar00rootroot00000000000000#ifndef TFIDF_CPP #define TFIDF_CPP template T sum_of_vector(const std::vector& v) { return accumulate(v.begin(), v.end(), 0); } // term frequency - inverse document frequency class Tfidf { public: Tfidf(long sym_num) : thn(0), thv(0), freq(vector (sym_num, 0)), a(vector(sym_num, 0)) {}; double get(long s) const {return thv - a[s];} // Alternate version, slightly weaker than the above according to the // PxTP 2013 paper evaluations. //double get(long s) const {return (1.0 / (1.0 + a[s]));} double get_sum() const { return (a.size() * thv) - sum_of_vector(a); } void add(const LVec &syms) { for (const auto& sym : syms) { freq[sym]++; a[sym] = log(freq[sym]); } thv = log(++thn); } void add_many(const LVecVec &syms) { for (const auto& sx : syms) for (const auto& sy : sx) freq[sy]++; for (unsigned i = 0; i < a.size(); ++i) a[i] = log(freq[i]); thn += syms.size(); thv = log(thn); } private: long thn; // number of theorems double thv; // logarithmic number of theorems vector freq; // feature frequency vector a; // logarithmic feature frequency }; #endif coqhammer-1.3.2-8.20/src/tactics/000077500000000000000000000000001471571225200163055ustar00rootroot00000000000000coqhammer-1.3.2-8.20/src/tactics/META.coq-hammer-tactics000066400000000000000000000010661471571225200224410ustar00rootroot00000000000000package "plugin" ( description = "Coq Hammer Tactics" requires = "coq-core.plugins.ltac coq-hammer-tactics.lib" archive(byte) = "hammer_tactics.cma" archive(native) = "hammer_tactics.cmxa" plugin(byte) = "hammer_tactics.cma" plugin(native) = "hammer_tactics.cmxs" directory = "." ) package "lib" ( description = "Coq Hammer Lib" requires = "coq-core.plugins.ltac" archive(byte) = "hammer_lib.cma" archive(native) = "hammer_lib.cmxa" plugin(byte) = "hammer_lib.cma" plugin(native) = "hammer_lib.cmxs" directory = "../lib" ) directory = "."coqhammer-1.3.2-8.20/src/tactics/dune000066400000000000000000000003121471571225200171570ustar00rootroot00000000000000(library (name hammer_tactics) (public_name coq-hammer-tactics.plugin) (synopsis "CoqHammer tactics") (libraries coq-core.plugins.ltac coq-hammer-tactics.lib)) (coq.pp (modules g_hammer_tactics)) coqhammer-1.3.2-8.20/src/tactics/g_hammer_tactics.mlg000066400000000000000000000271441471571225200223070ustar00rootroot00000000000000DECLARE PLUGIN "coq-hammer-tactics.plugin" { open Ltac_plugin open Stdarg open Tacarg open Pcoq.Prim open Pltac open Hammer_lib open Hammer_errors open Sauto open Tacopts open Tactics_main open Proofview.Notations } (*****************************************************************************) (* Argument parsing *) ARGUMENT EXTEND sauto_bopt | [ "on" ] -> { true } | [ "off" ] -> { false } END ARGUMENT EXTEND sauto_opts | [ "using" ne_uconstr_list_sep(l, ",") sauto_opts(sopts) ] -> { SOUse l :: sopts } | [ "unfolding" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOUnfold l :: sopts } | [ "inverting" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOInv l :: sopts } | [ "with" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SOBases l :: sopts } | [ "use" ":" ne_uconstr_list_sep(l, ",") sauto_opts(sopts) ] -> { SOUse l :: sopts } | [ "gen" ":" ne_uconstr_list_sep(l, ",") sauto_opts(sopts) ] -> { SOGen l :: sopts } | [ "unfold" ":" "*" sauto_opts(sopts) ] -> { SOUnfoldAll :: sopts } | [ "unfold" ":" "-" sauto_opts(sopts) ] -> { SOUnfoldNone :: sopts } | [ "unfold" ":" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOUnfold l :: sopts } | [ "unfold!" ":" "*" sauto_opts(sopts) ] -> { SOAlwaysUnfoldAll :: sopts } | [ "unfold!" ":" "-" sauto_opts(sopts) ] -> { SOAlwaysUnfoldNone :: sopts } | [ "unfold!" ":" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOAlwaysUnfold l :: sopts } | [ "inv" ":" "*" sauto_opts(sopts) ] -> { SOInvAll :: sopts } | [ "inv" ":" "-" sauto_opts(sopts) ] -> { SOInv [] :: sopts } | [ "inv" ":" "never" sauto_opts(sopts) ] -> { SOInvNone :: sopts } | [ "inv" ":" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOInv l :: sopts } | [ "ctrs" ":" "*" sauto_opts(sopts) ] -> { SOCtrsAll :: sopts } | [ "ctrs" ":" "-" sauto_opts(sopts) ] -> { SOCtrs [] :: sopts } | [ "ctrs" ":" "never" sauto_opts(sopts) ] -> { SOCtrsNone :: sopts } | [ "ctrs" ":" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOCtrs l :: sopts } | [ "cases" ":" "*" sauto_opts(sopts) ] -> { SOCaseSplitAll :: sopts } | [ "cases" ":" "-" sauto_opts(sopts) ] -> { SOCaseSplit [] :: sopts } | [ "cases" ":" "never" sauto_opts(sopts) ] -> { SOCaseSplitNone :: sopts } | [ "cases" ":" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOCaseSplit l :: sopts } | [ "split" ":" "*" sauto_opts(sopts) ] -> { SOSimpleSplitAll :: sopts } | [ "split" ":" "-" sauto_opts(sopts) ] -> { SOSimpleSplit [] :: sopts } | [ "split" ":" "never" sauto_opts(sopts) ] -> { SOSimpleSplitNone :: sopts } | [ "split" ":" ne_reference_list_sep(l, ",") sauto_opts(sopts) ] -> { SOSimpleSplit l :: sopts } | [ "db" ":" "*" sauto_opts(sopts) ] -> { SOBasesAll :: sopts } | [ "db" ":" "-" sauto_opts(sopts) ] -> { SOBases [] :: sopts } | [ "db" ":" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SOBases l :: sopts } | [ "db+" ":" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SOBasesAdd l :: sopts } | [ "rew:db" ":" "-" sauto_opts(sopts) ] -> { SORewBases [] :: sopts } | [ "rew:db" ":" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SORewBases l :: sopts } | [ "rew:db+" ":" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SORewBasesAdd l :: sopts } | [ "hint:db" ":" "*" sauto_opts(sopts) ] -> { SOHintBasesAll :: sopts } | [ "hint:db" ":" "-" sauto_opts(sopts) ] -> { SOHintBases [] :: sopts } | [ "hint:db" ":" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SOHintBases l :: sopts } | [ "hint:db+" ":" ne_preident_list_sep(l, ",") sauto_opts(sopts) ] -> { SOHintBasesAdd l :: sopts } | [ "finish" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOFinish tac :: sopts } | [ "final" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOFinal tac :: sopts } | [ "solve" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOSolve tac :: sopts } | [ "simp" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOSimp tac :: sopts } | [ "ssimp" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOSSimp tac :: sopts } | [ "solve+" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOSolveAdd tac :: sopts } | [ "simp+" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOSimpAdd tac :: sopts } | [ "ssimp+" ":" tactic4(tac) sauto_opts(sopts) ] -> { SOSSimpAdd tac :: sopts } | [ "fwd" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOForward b :: sopts } | [ "ecases" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEagerCaseSplit b :: sopts } | [ "sinv" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOSimpleInvert b :: sopts } | [ "einv" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEagerInvert b :: sopts } | [ "ered" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEagerReduce b :: sopts } | [ "erew" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEagerRewrite b :: sopts } | [ "drew" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SODirectedRewrite b :: sopts } | [ "urew" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOUndirectedRewrite b :: sopts } | [ "rew" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SORewrite b :: sopts } | [ "brefl" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOReflect b :: sopts } | [ "b" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOReflect b :: sopts } | [ "brefl!" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOReflectRaw b :: sopts } | [ "b!" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOReflectRaw b :: sopts } | [ "red" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOReduce b :: sopts } | [ "sapp" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOSapply b :: sopts } | [ "limit" ":" integer(i) sauto_opts(sopts) ] -> { SOLimit i :: sopts } | [ "depth" ":" integer(i) sauto_opts(sopts) ] -> { SODepth i :: sopts } | [ "time" ":" integer(i) sauto_opts(sopts) ] -> { SOTimeout i :: sopts } | [ "exh" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOExhaustive b :: sopts } | [ "lia" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOLia b :: sopts } | [ "sig" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOSig b :: sopts } | [ "prf" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOPrf b :: sopts } | [ "dep" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SODep b :: sopts } | [ "dep!" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SODepRaw b :: sopts } | [ "eager" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEager b :: sopts } | [ "e" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEager b :: sopts } | [ "lazy" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEager (not b) :: sopts } | [ "l" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOEager (not b) :: sopts } | [ "quick" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOQuick b :: sopts } | [ "q" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { SOQuick b :: sopts } | [ "lq" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { if b then SOEager false :: SOQuick true :: sopts else sopts } | [ "lb" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { if b then SOEager false :: SOReflect true :: sopts else sopts } | [ "qb" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { if b then SOQuick true :: SOReflect true :: sopts else sopts } | [ "lqb" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { if b then SOEager false :: SOQuick true :: SOReflect true :: sopts else sopts } | [ "qb!" ":" sauto_bopt(b) sauto_opts(sopts) ] -> { if b then SOQuick true :: SOReflectRaw true :: sopts else sopts } | [ ] -> { [SONop] } END (*****************************************************************************) (* Tactics *) TACTIC EXTEND Hammer_simple_splitting | [ "simple_splitting" ] -> { simple_splitting { (default_s_opts ()) with s_simple_splits = SAll } } | [ "simple_splitting" "logic" ] -> { simple_splitting (default_s_opts ()) } END TACTIC EXTEND Hammer_eager_inverting | [ "eager_inverting" ] -> { eager_inverting (default_s_opts ()) } | [ "eager_inverting_dep" ] -> { eager_inverting { (default_s_opts ()) with s_dep = true } } END TACTIC EXTEND Hammer_sunfolding | [ "sunfolding" ] -> { sunfolding true } | [ "sunfolding" "weak" ] -> { sunfolding false } END TACTIC EXTEND Hammer_srun | [ "srun" tactic4(tac) sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l (fun opts -> sinit opts <*> Tacticals.tclSOLVE [ Hhutils.tacinterp tac ]) "srun failed" } END TACTIC EXTEND Hammer_scongruence | [ "scongruence" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l scongruence "scongruence failed" } END TACTIC EXTEND Hammer_sfirstorder | [ "sfirstorder" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l sfirstorder "sfirstorder failed" } END TACTIC EXTEND Hammer_strivial | [ "strivial" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l strivial "strivial failed" } END TACTIC EXTEND Hammer_sauto | [ "sauto" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l sauto "sauto failed" } END TACTIC EXTEND Hammer_hauto | [ "hauto" sauto_opts(l) ] -> { try_usolve (hauto_s_opts ()) l sauto "hauto failed" } END TACTIC EXTEND Hammer_qauto | [ "qauto" sauto_opts(l) ] -> { try_usolve (qauto_s_opts ()) l sauto "qauto failed" } END TACTIC EXTEND Hammer_cauto | [ "cauto" sauto_opts(l) ] -> { let opts = { (default_s_opts ()) with s_forwarding = false } in try_usolve opts l sauto "cauto failed" } END TACTIC EXTEND Hammer_ssimpl | [ "ssimpl" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l ssimpl "ssimpl failed" } END TACTIC EXTEND Hammer_csimpl | [ "csimpl" sauto_opts(l) ] -> { let opts = { (default_s_opts ()) with s_forwarding = false } in try_usolve opts l ssimpl "csimpl failed" } END TACTIC EXTEND Hammer_qsimpl | [ "qsimpl" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l qsimpl "qsimpl failed" } END TACTIC EXTEND Hammer_sintuition | [ "sintuition" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l sintuition "sintuition failed" } END TACTIC EXTEND Hammer_scrush | [ "scrush" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l scrush "scrush failed" } END TACTIC EXTEND Hammer_hcrush | [ "hcrush" sauto_opts(l) ] -> { try_usolve (hauto_s_opts ()) l scrush "hcrush failed" } END TACTIC EXTEND Hammer_qcrush | [ "qcrush" sauto_opts(l) ] -> { try_usolve (qauto_s_opts ()) l scrush "qcrush failed" } END TACTIC EXTEND Hammer_fcrush | [ "fcrush" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l fcrush "fcrush failed" } END TACTIC EXTEND Hammer_hfcrush | [ "hfcrush" sauto_opts(l) ] -> { try_usolve (hauto_s_opts ()) l fcrush "hfcrush failed" } END TACTIC EXTEND Hammer_qfcrush | [ "qfcrush" sauto_opts(l) ] -> { try_usolve (qauto_s_opts ()) l fcrush "qfcrush failed" } END TACTIC EXTEND Hammer_ecrush | [ "ecrush" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l ecrush "ecrush failed" } END TACTIC EXTEND Hammer_hecrush | [ "hecrush" sauto_opts(l) ] -> { try_usolve (hauto_s_opts ()) l ecrush "hecrush failed" } END TACTIC EXTEND Hammer_qecrush | [ "qecrush" sauto_opts(l) ] -> { try_usolve (qauto_s_opts ()) l ecrush "qecrush failed" } END TACTIC EXTEND Hammer_sblast | [ "sblast" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l sblast "sblast failed" } END TACTIC EXTEND Hammer_qblast | [ "qblast" sauto_opts(l) ] -> { try_usolve (default_s_opts ()) l qblast "qblast failed" } END TACTIC EXTEND Hammer_sauto_actions | [ "sauto_actions" sauto_opts(l) ] -> { try_tactic (fun () -> interp_opts (default_s_opts ()) l print_actions) } END TACTIC EXTEND Hammer_use | [ "use" ne_uconstr_list_sep(l, ",") ] -> { try_tactic (fun () -> use_lemmas ist l) } END TACTIC EXTEND Hammer_sauto_hbest | [ "hbest" sauto_opts(l) ] -> { Tacbest.find_best_tactic (Tacbest.hbest_tactics l) l "hbest" } END TACTIC EXTEND Hammer_sauto_sbest | [ "sbest" sauto_opts(l) ] -> { Tacbest.find_best_tactic (Tacbest.sbest_tactics l) l "sbest" } END TACTIC EXTEND Hammer_sauto_best | [ "best" sauto_opts(l) ] -> { Tacbest.find_best_tactic (Tacbest.best_tactics l) l "best" } END coqhammer-1.3.2-8.20/src/tactics/hammer_tactics.mlpack000066400000000000000000000000641471571225200224610ustar00rootroot00000000000000Sauto Tacopts Tacbest Tactics_main G_hammer_tactics coqhammer-1.3.2-8.20/src/tactics/sauto.ml000066400000000000000000001275371471571225200200110ustar00rootroot00000000000000(* sauto -- implementation *) open Names open Environ open Tactypes open Locus open Proofview.Notations open Ltac_plugin open Hammer_lib module Utils = Hhutils module Lpo = Hhlpo type 'a soption = SNone | SAll | SSome of 'a type s_opts = { s_exhaustive : bool; s_hints : bool; s_leaf_tac : unit Proofview.tactic; s_leaf_nolia_tac : unit Proofview.tactic; s_solve_tac : unit Proofview.tactic; s_simpl_tac : unit Proofview.tactic; s_simpl_nolia_tac : unit Proofview.tactic; s_ssimpl_tac : unit Proofview.tactic; s_ssimpl_nolia_tac : unit Proofview.tactic; s_unfolding : Constant.t list soption; s_always_unfold : Constant.t list soption; s_constructors : inductive list soption; s_simple_splits : inductive list soption; s_case_splits : inductive list soption; s_inversions : inductive list soption; s_rew_bases : string list; s_hint_bases : Hints.hint_db list; s_reflect : bool; s_eager_case_splitting : bool; s_eager_reducing : bool; s_eager_rewriting : bool; s_eager_inverting : bool; s_simple_inverting : bool; s_forwarding : bool; s_reducing : bool; s_directed_rewriting : bool; s_undirected_rewriting : bool; s_aggressive_unfolding : bool; s_sapply : bool; s_depth_cost_model : bool; s_limit : int; s_simpl_sigma : bool; s_lia : bool; s_dep : bool; s_genproofs : bool; } let default_s_opts () = { s_exhaustive = false; s_hints = true; s_leaf_tac = Utils.ltac_apply "Tactics.leaf_solve" []; s_leaf_nolia_tac = Utils.ltac_apply "Tactics.leaf_solve_nolia" []; s_solve_tac = Utils.ltac_apply "fail" []; s_simpl_tac = Tacticals.tclTRY (Utils.ltac_apply "Tactics.simpl_solve" []); s_simpl_nolia_tac = Tacticals.tclTRY (Utils.ltac_apply "Tactics.simpl_solve_nolia" []); s_ssimpl_tac = Tacticals.tclTRY (Utils.ltac_apply "Tactics.ssolve" []); s_ssimpl_nolia_tac = Tacticals.tclTRY (Utils.ltac_apply "Tactics.ssolve_nolia" []); s_unfolding = SSome []; s_always_unfold = SNone; s_constructors = SAll; s_simple_splits = SSome []; s_case_splits = SAll; s_inversions = SAll; s_rew_bases = []; s_hint_bases = []; s_reflect = false; s_eager_case_splitting = true; s_eager_reducing = true; s_eager_rewriting = true; s_eager_inverting = true; s_simple_inverting = true; s_forwarding = true; s_reducing = true; s_directed_rewriting = true; s_undirected_rewriting = true; s_aggressive_unfolding = false; s_sapply = true; s_depth_cost_model = false; s_limit = 1000; s_simpl_sigma = true; s_lia = true; s_dep = false; s_genproofs = false; } let hauto_s_opts () = { (default_s_opts ()) with s_inversions = SSome []; s_constructors = SSome [] } let eauto_tac = Eauto.gen_eauto [] (Some []) let congr_tac () = Utils.ltac_apply "Tactics.congr_tac" [] let lia_tac () = Utils.ltac_apply "Tactics.lia_tac" [] let qauto_s_opts () = { (hauto_s_opts ()) with s_simpl_tac = Tacticals.tclIDTAC; s_simpl_nolia_tac = Tacticals.tclIDTAC; s_leaf_tac = (eauto_tac <*> Tacticals.tclTRY (congr_tac ()) <*> lia_tac ()); s_leaf_nolia_tac = (eauto_tac <*> congr_tac ()); s_sapply = false; s_limit = 100; s_lia = false } let set_dep_opts b opts = if b then { opts with s_dep = true; s_genproofs = true; s_eager_inverting = false; s_simple_inverting = false } else { opts with s_dep = false } let set_eager_opts b opts = { opts with s_eager_reducing = b; s_eager_rewriting = b; s_eager_case_splitting = b; s_eager_inverting = b; s_simple_inverting = b; s_simpl_sigma = b } let set_quick_opts b opts = if b then { opts with s_simpl_tac = Tacticals.tclIDTAC; s_simpl_nolia_tac = Tacticals.tclIDTAC; s_leaf_tac = Utils.ltac_apply "Tactics.sdone_tac" []; s_leaf_nolia_tac = Utils.ltac_apply "Tactics.sdone_nolia_tac" []; s_sapply = false; s_lia = false } else opts let set_brefl_opts b opts = if b then { opts with s_reflect = true; s_eager_case_splitting = false } else opts let set_rew_opts b opts = if b then { opts with s_directed_rewriting = true; s_undirected_rewriting = true } else { opts with s_directed_rewriting = false; s_undirected_rewriting = false } let with_reduction opts tac1 tac2 = if opts.s_eager_reducing && opts.s_reducing then tac1 else tac2 (*****************************************************************************************) let coq_equality = lazy (Utils.get_inductive "Init.Logic.eq") let logic_constants = lazy [ Utils.get_const "Init.Logic.iff"; Utils.get_const "Init.Logic.not"; ] let logic_inductives = lazy [ Utils.get_inductive "Init.Logic.and"; Utils.get_inductive "Init.Logic.or"; Utils.get_inductive "Init.Logic.ex"; Utils.get_inductive "Init.Datatypes.prod"; Utils.get_inductive "Init.Specif.sumbool"; Utils.get_inductive "Init.Specif.sig"; Utils.get_inductive "Init.Datatypes.sum"; Utils.get_inductive "Init.Specif.sigT"; Utils.get_inductive "Init.Logic.False"; Utils.get_inductive "Init.Logic.eq"; ] let split_inductives = lazy [ Utils.get_inductive "Init.Logic.and"; Utils.get_inductive "Init.Logic.ex"; Utils.get_inductive "Init.Datatypes.prod"; Utils.get_inductive "Init.Specif.sig"; Utils.get_inductive "Init.Specif.sigT"; ] type 'a in_lazy_ref = | LazyRef of 'a Lazy.t | NotLazy of 'a let lazyref x = ref (LazyRef x) let lazyget x = match !x with | LazyRef (lazy v) -> x := NotLazy v; v | NotLazy v -> v let lazyset x v = x := NotLazy v let unfolding_hints = lazyref logic_constants let constructor_hints = lazyref logic_inductives let simple_split_hints = lazyref split_inductives let case_split_hints = ref [] let inversion_hints = lazyref logic_inductives let add_unfold_hint c = lazyset unfolding_hints (c :: lazyget unfolding_hints) let add_ctrs_hint c = lazyset constructor_hints (c :: lazyget constructor_hints) let add_simple_split_hint c = lazyset simple_split_hints (c :: lazyget simple_split_hints) let add_case_split_hint c = case_split_hints := c :: !case_split_hints let add_inversion_hint c = lazyset inversion_hints (c :: lazyget inversion_hints) (*****************************************************************************************) type action = ActApply of Id.t | ActRewriteLR of Id.t | ActRewriteRL of Id.t | ActRewrite of Id.t | ActInvert of Id.t | ActUnfold of Constant.t | ActCaseUnfold of Constant.t | ActDestruct of EConstr.t | ActHint of Utils.hint | ActSolve | ActConstructor | ActIntro | ActReduce | ActFEqual let action_to_string act = match act with | ActApply id -> "apply " ^ Id.to_string id | ActRewriteLR id -> "rewrite -> " ^ Id.to_string id | ActRewriteRL id -> "rewrite <- " ^ Id.to_string id | ActRewrite id -> "srewrite " ^ Id.to_string id | ActInvert id -> "invert " ^ Id.to_string id | ActUnfold c -> "unfold " ^ Constant.to_string c | ActCaseUnfold c -> "case-unfold " ^ Constant.to_string c | ActDestruct t -> "destruct " ^ Utils.constr_to_string Evd.empty t | ActHint h -> Utils.hint_to_string h | ActSolve -> "solve" | ActConstructor -> "constructor" | ActIntro -> "intro" | ActReduce -> "reduce" | ActFEqual -> "f_equal" let print_search_actions actions = Hhlib.oiter print_string (fun (cost, br, act) -> print_string "("; print_int cost; print_string ", "; print_int br; print_string ", "; print_string (action_to_string act); print_string ")") "; " actions; print_newline () (*****************************************************************************************) let mk_tac_arg_id id = Tacexpr.Reference (Locus.ArgVar CAst.(make id)) let mk_tac_arg_constr t = Tacexpr.ConstrMayEval (Genredexpr.ConstrTerm t) let erewrite b_all l2r id = let c env sigma = (sigma, (EConstr.mkVar id, NoBindings)) in Equality.general_multi_rewrite true [l2r, Equality.Precisely 1, Some false, c] Locus.({onhyps = if b_all then None else Some []; concl_occs = AllOccurrences}) None let simp_hyps_tac () = Utils.ltac_apply "Tactics.simp_hyps" [] let esimp_hyps_tac () = Utils.ltac_apply "Tactics.esimp_hyps" [] let fail_tac () = Utils.ltac_apply "fail" [] let sinvert_tac id = Tacticals.tclPROGRESS (Utils.ltac_apply "Tactics.sinvert" [mk_tac_arg_id id]) let seinvert_tac id = Tacticals.tclPROGRESS (Utils.ltac_apply "Tactics.seinvert" [mk_tac_arg_id id]) let sdepinvert_tac id = Tacticals.tclPROGRESS (Utils.ltac_apply "Tactics.sdepinvert" [mk_tac_arg_id id]) let sedepinvert_tac id = Tacticals.tclPROGRESS (Utils.ltac_apply "Tactics.sedepinvert" [mk_tac_arg_id id]) let ssubst_tac () = Utils.ltac_apply "Tactics.ssubst" [] let subst_simpl_tac () = Utils.ltac_apply "Tactics.subst_simpl" [] let srewrite_tac id = Tacticals.tclPROGRESS (Utils.ltac_apply "Tactics.srewrite" [mk_tac_arg_id id]) let intros_until_atom_tac () = Utils.ltac_apply "Tactics.intros_until_atom" [] let simple_inverting_tac opts = Utils.ltac_apply (if opts.s_dep then with_reduction opts "Tactics.simple_inverting_dep" "Tactics.simple_inverting_dep_nored" else with_reduction opts "Tactics.simple_inverting" "Tactics.simple_inverting_nored") [] let simple_invert_tac opts id = Utils.ltac_apply (if opts.s_dep then with_reduction opts "Tactics.simple_invert_dep" "Tactics.simple_invert_dep_nored" else with_reduction opts "Tactics.simple_invert" "Tactics.simple_invert_nored") [mk_tac_arg_id id] let sapply_tac id = Utils.ltac_apply "Tactics.sapply" [mk_tac_arg_id id] let case_splitting_tac opts = Utils.ltac_apply (if opts.s_dep then with_reduction opts "Tactics.case_splitting_dep" "Tactics.case_splitting_dep_nored" else with_reduction opts "Tactics.case_splitting" "Tactics.case_splitting_nored") [] let case_splitting_concl_tac opts = Utils.ltac_apply (if opts.s_dep then with_reduction opts "Tactics.case_splitting_concl_dep" "Tactics.case_splitting_concl_dep_nored" else with_reduction opts "Tactics.case_splitting_concl" "Tactics.case_splitting_concl_nored") [] let case_splitting_on_tac opts ind = Utils.ltac_eval (if opts.s_dep then with_reduction opts "Tactics.case_splitting_on_dep" "Tactics.case_splitting_on_dep_nored" else with_reduction opts "Tactics.case_splitting_on" "Tactics.case_splitting_on_nored") [Tacinterp.Value.of_constr (EConstr.mkInd ind)] let case_splitting_concl_on_tac opts ind = Utils.ltac_eval (if opts.s_dep then with_reduction opts "Tactics.case_splitting_concl_on_dep" "Tactics.case_splitting_concl_on_dep_nored" else with_reduction opts "Tactics.case_splitting_concl_on" "Tactics.case_splitting_concl_on_nored") [Tacinterp.Value.of_constr (EConstr.mkInd ind)] let forwarding_tac () = Utils.ltac_apply "Tactics.forwarding" [] let forwarding_nored_tac () = Utils.ltac_apply "Tactics.forwarding_nored" [] let srewriting_tac () = Utils.ltac_apply "Tactics.srewriting" [] let bnat_reflect_tac () = Utils.ltac_apply "Tactics.bnat_reflect" [] let bool_reflect_tac () = Utils.ltac_apply "Tactics.bool_reflect" [] let fullunfold_tac t = Utils.ltac_apply "Tactics.fullunfold" [mk_tac_arg_constr t] let red_in_concl_tac () = Utils.ltac_apply "Tactics.red_in_concl" [] let red_in_all_tac () = Utils.ltac_apply "Tactics.red_in_all" [] let dsolve_tac () = Utils.ltac_apply "Tactics.dsolve" [] let qforwarding_tac () = Utils.ltac_apply "Tactics.qforwarding" [] let instering_tac () = Utils.ltac_apply "Tactics.instering" [] let einstering_tac () = Utils.ltac_apply "Tactics.einstering" [] let f_equal_tac () = Utils.ltac_apply "Tactics.f_equal_tac" [] let simpl_sigma_tac () = Utils.ltac_apply "Tactics.simpl_sigma" [] let generalize_proofs_tac () = Utils.ltac_apply "Tactics.generalize_proofs" [] let unfold_local_defs_tac () = Utils.ltac_apply "Tactics.unfold_local_defs" [] (*****************************************************************************************) let eq_ind (mi1, i1) (mi2, i2) = i1 = i2 && QMutInd.equal (Global.env ()) mi1 mi2 let rec mem_constr evd x lst = match lst with | [] -> false | h :: t -> if EConstr.eq_constr evd x h then true else mem_constr evd x t let rec mem_ind ind lst = match lst with | [] -> false | h :: t -> if eq_ind ind h then true else mem_ind ind t let rec mem_const c lst = match lst with | [] -> false | h :: t -> if QConstant.equal (Global.env ()) c h then true else mem_const c t (*****************************************************************************************) module IndHash = struct type t = inductive let equal = eq_ind let hash (mi, _) = QMutInd.hash (Global.env ()) mi end module IndMemo = Hhlib.MakeMemo(IndHash) let memoize_ind = IndMemo.memoize (*****************************************************************************************) let opt b tac = if b then tac else Tacticals.tclIDTAC let autorewrite b_all bases = if bases = [] then Proofview.tclUNIT () else Autorewrite.auto_multi_rewrite bases { onhyps = if b_all then None else Some []; concl_occs = AllOccurrences } let subst_simpl opts = opt opts.s_simpl_sigma (simpl_sigma_tac ()) <*> if opts.s_eager_reducing && opts.s_reducing then subst_simpl_tac () else ssubst_tac () let sinvert opts id = let sinv = if opts.s_exhaustive then if opts.s_dep then sedepinvert_tac id else seinvert_tac id else if opts.s_dep then sdepinvert_tac id else sinvert_tac id in sinv <*> subst_simpl opts let reduce_concl opts = if opts.s_eager_reducing && opts.s_reducing then red_in_concl_tac () else Proofview.tclUNIT () (*****************************************************************************************) let leaf_tac opts = if opts.s_lia then opts.s_leaf_tac else opts.s_leaf_nolia_tac let simpl_tac opts = if opts.s_lia then opts.s_simpl_tac else opts.s_simpl_nolia_tac let ssimpl_tac opts = if opts.s_lia then opts.s_ssimpl_tac else opts.s_ssimpl_nolia_tac (*****************************************************************************************) let get_consts evd lst = Hhlib.sort_uniq Stdlib.compare (List.concat (List.map begin fun t -> Utils.fold_constr begin fun n acc t -> let open Constr in let open EConstr in match kind evd t with | Const (c, _) -> c :: acc | _ -> acc end [] evd t end lst)) let is_simple_unfold b_aggressive c = match Global.body_of_constant Library.indirect_accessor c with | Some (b, _, _) -> begin let t = EConstr.of_constr b in let body = Utils.drop_all_lambdas Evd.empty t in let open Constr in let open EConstr in match kind Evd.empty body with | Prod _ | App _ | Const _ | Ind _ | Sort _ | Var _ | Rel _ | Construct _ | Int _ -> true | Case _ | LetIn _ | Cast _ -> b_aggressive | _ -> false end | None -> false (* -1 if not a case unfold *) let case_unfold_cost c = match Global.body_of_constant Library.indirect_accessor c with | Some (b, _, _) -> begin let t = EConstr.of_constr b in let lambdas = Utils.take_all_lambdas Evd.empty t in let body = Utils.drop_all_lambdas Evd.empty t in let open Constr in let open EConstr in match kind Evd.empty body with | Case _ -> List.length lambdas * 10 + 10 | _ -> -1 end | None -> -1 let unfold c = Tactics.unfold_constr (GlobRef.ConstRef c) let fullunfold c = fullunfold_tac (DAst.make (Glob_term.GRef (GlobRef.ConstRef c, None)), None) let fullunfolding opts = match opts.s_always_unfold with | SSome lst -> List.fold_left (fun tac c -> tac <*> fullunfold c) Tacticals.tclIDTAC lst | SNone -> Tacticals.tclIDTAC | SAll -> Utils.ltac_apply "Tactics.fullunfold_all" [] let sunfold b_aggressive c = if is_simple_unfold b_aggressive c then fullunfold c else Tacticals.tclIDTAC let sdestruct opts t = if opts.s_dep then Utils.ltac_eval "Tactics.sdepdestruct" [Tacinterp.Value.of_constr t] else Utils.ltac_eval "Tactics.sdestruct" [Tacinterp.Value.of_constr t] (* TODO: port gunfolding from Reconstr.v *) let unfolding opts = let do_unfolding lst = Tacticals.tclREPEAT (List.fold_left (fun acc c -> sunfold opts.s_aggressive_unfolding c <*> acc) Tacticals.tclIDTAC lst) in match opts.s_unfolding with | SSome lst -> if opts.s_hints then do_unfolding (lazyget unfolding_hints @ lst) else do_unfolding lst | SAll -> Proofview.Goal.enter begin fun gl -> do_unfolding (get_consts (Proofview.Goal.sigma gl) (Proofview.Goal.concl gl :: List.map snd (Utils.get_hyps gl))) end | SNone -> Tacticals.tclIDTAC let sunfolding b_aggressive = unfolding { (default_s_opts ()) with s_unfolding = SAll; s_aggressive_unfolding = b_aggressive } (*****************************************************************************************) let in_sopt_list mem b_hints hints x opt = match opt with | SAll -> true | SSome lst when mem x lst || (b_hints && mem x hints) -> true | _ -> false let in_sopt_list_ind = in_sopt_list mem_ind let in_sopt_list_const = in_sopt_list mem_const let is_constr_non_recursive ind t = let (prods, _, _) = Utils.destruct_prod Evd.empty (EConstr.of_constr t) in let t2 = List.fold_right (fun (name, types) acc -> EConstr.mkLambda (name, types, acc)) prods (EConstr.mkRel 0) in Utils.fold_constr begin fun k acc x -> let open Constr in let open EConstr in match kind Evd.empty x with | Ind (ind2, _) when eq_ind ind2 ind -> false | Rel n when n > k -> false | _ -> acc end true Evd.empty t2 let has_dangling_evars evd t = let (prods, head, args) = Utils.destruct_prod evd t in let app = EConstr.mkApp (head, args) in let rec go t k = let open Constr in let open EConstr in match kind evd t with | Prod (na, ty, body) -> if not (Utils.rel_occurs evd body [1]) then go body (k - 1) else if Utils.rel_occurs evd app [k] then go body (k - 1) else true | _ -> false in go t (List.length prods) (* check if the inductive type is non-recursive with at most two constructors *) let is_eager_ind = memoize_ind begin fun ind -> if Utils.get_ind_nargs ind = 0 then false else List.for_all (is_constr_non_recursive ind) (Utils.get_ind_constrs ind) end (* check if the inductive type is non-recursive with exactly one constructor and no dangling evars *) let is_simple_ind = memoize_ind begin fun ind -> let cstrs = Utils.get_ind_constrs ind in match cstrs with | [ t ] -> is_constr_non_recursive ind t && not (has_dangling_evars Evd.empty (EConstr.of_constr t)) | _ -> false end let is_simple_split opts evd t = let open Constr in let open EConstr in let head = Utils.get_head_red evd t in match kind evd head with | Ind (ind, _) when is_simple_ind ind -> in_sopt_list_ind opts.s_hints (lazyget simple_split_hints) ind opts.s_simple_splits | _ -> false let is_case_split opts evd t = if opts.s_case_splits = SNone then false else try Utils.fold_constr_shallow begin fun acc t -> let open Constr in let open EConstr in match kind evd t with | Case (ci, _, _, _, _, _, _) when in_sopt_list_ind opts.s_hints !case_split_hints ci.ci_ind opts.s_case_splits -> raise Exit | _ -> acc end false evd t with Exit -> true let is_inversion opts evd ind args = in_sopt_list_ind opts.s_hints (lazyget inversion_hints) ind opts.s_inversions && if eq_ind ind (Lazy.force coq_equality) then match args with | [|_; t1; t2|] -> begin let open Constr in let open EConstr in match (kind evd (Utils.get_app_head evd t1), kind evd (Utils.get_app_head evd t2)) with | (Construct _, Construct _) -> true | _ -> false end | _ -> false else true let is_eager_inversion opts evd t = let open Constr in let open EConstr in let (_, head, args) = Utils.destruct_app_red evd t in match kind evd head with | Ind (ind, _) when is_eager_ind ind -> is_inversion opts evd ind args | _ -> false (*****************************************************************************************) let is_equality evd t = let open Constr in let open EConstr in match kind evd t with | Ind(ind, _) when eq_ind ind (Lazy.force coq_equality) -> true | _ -> false let with_equality evd head args default f = if is_equality evd head then let args = Array.to_list args in match Hhlib.drop (List.length args - 2) args with | [t1; t2] -> f t1 t2 | _ -> default else default let is_unorientable_equality evd head args = with_equality evd head args false begin fun t1 t2 -> not (Lpo.lpo evd t1 t2 || Lpo.lpo evd t2 t1) end (*****************************************************************************************) let is_true_const = lazy (Utils.get_const "Init.Datatypes.is_true") let is_coercion evd t = let open Constr in let open EConstr in match kind evd t with | Const(c, _) when QConstant.equal (Global.env ()) c (Lazy.force is_true_const) -> true | _ -> false (*****************************************************************************************) let rec brepeat n t = if n = 0 then Proofview.tclUNIT () else Proofview.tclINDEPENDENT begin Proofview.tclIFCATCH t (fun () -> Proofview.tclCHECKINTERRUPT <*> brepeat (n - 1) t) (fun e -> Tacticals.catch_failerror e <*> Proofview.tclUNIT ()) end let repeat t = brepeat 8 (Tacticals.tclPROGRESS t) let repeat2 tac1 tac2 = Tacticals.tclTHEN tac1 (repeat (Tacticals.tclTHEN (Tacticals.tclPROGRESS tac2) tac1)) let (<~>) = repeat2 let rec repeat_when p f = Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in let rec go hyps = match hyps with | [] -> Tacticals.tclIDTAC | (id, hyp) :: hyps' -> if p evd hyp then f id <*> repeat_when p f else go hyps' in go (Utils.get_hyps gl) end let rec do_when p f forbidden_ids = Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in let rec go hyps = match hyps with | [] -> Tacticals.tclIDTAC | (id, hyp) :: hyps' -> if not (List.memq id forbidden_ids) && p evd hyp then f id <*> do_when p f (id :: forbidden_ids) else go hyps' in go (Utils.get_hyps gl) end let do_when p f = do_when p f [] let autorewriting b_all opts = autorewrite b_all opts.s_rew_bases let rec simple_splitting opts = if opts.s_simple_splits = SNone then Proofview.tclUNIT () else Proofview.Goal.enter begin fun gl -> let goal = Proofview.Goal.concl gl in let evd = Proofview.Goal.sigma gl in if is_simple_split opts evd goal then Tactics.constructor_tac true None 1 NoBindings <*> reduce_concl opts <*> simple_splitting opts else Tacticals.tclIDTAC end let case_splitting b_all opts = match opts.s_case_splits with | SAll -> if b_all then case_splitting_tac opts else case_splitting_concl_tac opts | SNone -> Tacticals.tclIDTAC | SSome lst -> let csplit = if b_all then case_splitting_on_tac opts else case_splitting_concl_on_tac opts in List.fold_left (fun tac ind -> tac <*> csplit ind) Tacticals.tclIDTAC (!case_split_hints @ lst) let eager_inverting opts = match opts.s_inversions with | SNone -> Tacticals.tclIDTAC | _ -> do_when begin fun evd hyp -> let (_, head, args) = Utils.destruct_app_red evd hyp in let open Constr in let open EConstr in match kind evd head with | Ind(ind, _) when is_eager_inversion opts evd hyp -> true | _ -> false end (fun id -> sinvert opts id <*> subst_simpl opts) let simple_inverting opts = match opts.s_inversions with | SAll -> simple_inverting_tac opts | SNone -> Tacticals.tclIDTAC | _ -> repeat_when begin fun evd hyp -> let (_, head, args) = Utils.destruct_app_red evd hyp in let open Constr in let open EConstr in match kind evd head with | Ind(ind, _) when is_inversion opts evd ind args -> true | _ -> false end (simple_invert_tac opts) let simplify opts = let simpl1 = simp_hyps_tac () <~> opt opts.s_reflect (bnat_reflect_tac ()) <~> opt opts.s_eager_case_splitting (case_splitting true opts) <~> simpl_tac opts <~> reduce_concl opts <~> (Tacticals.tclPROGRESS begin opt opts.s_genproofs (generalize_proofs_tac ()) <*> intros_until_atom_tac () end <*> subst_simpl opts) <~> simple_splitting opts <~> autorewriting true opts <~> opt (opts.s_eager_rewriting && opts.s_directed_rewriting) (srewriting_tac ()) <~> opt opts.s_eager_inverting (eager_inverting opts) <~> opt opts.s_simple_inverting (simple_inverting opts) in fullunfolding opts <*> opt opts.s_reflect (bool_reflect_tac ()) <*> (if opts.s_forwarding then simpl1 <*> (Tacticals.tclTRY (Tacticals.tclPROGRESS (with_reduction opts (forwarding_tac ()) (forwarding_nored_tac ())) <*> simpl1)) else simpl1) <*> Tacticals.tclTRY opts.s_solve_tac let simplify_concl opts = (reduce_concl opts <~> autorewriting false opts) <*> if opts.s_eager_case_splitting then Tacticals.tclTRY (Tacticals.tclPROGRESS (case_splitting false opts) <*> simplify opts) else Proofview.tclUNIT () (*****************************************************************************************) let eval_hyp evd (id, hyp) = let (prods, head0, head, args) = Utils.destruct_prod_red evd hyp in let app = EConstr.mkApp (head, args) in let n = List.length prods in let rec go t m m' k = let open Constr in let open EConstr in match kind evd t with | Prod (na, ty, body) -> if not (Utils.rel_occurs evd body [1]) then go body (m + 1) m' (k - 1) else if Utils.rel_occurs evd app [k] then go body m m' (k - 1) else go body m (m' + 1) (k - 1) | _ -> (m, m') in let (num_subgoals, num_dangling_evars) = go hyp 0 0 n in (id, hyp, n + num_subgoals * 10 + num_dangling_evars * 10, num_subgoals, (prods, head0, head, args)) let hyp_cost evd hyp = match eval_hyp evd (None, hyp) with | (_, _, cost, _, _) -> cost let hyp_nsubgoals evd hyp = match eval_hyp evd (None, hyp) with | (_, _, _, num_subgoals, _) -> num_subgoals let constrs_cost = memoize_ind begin fun ind -> let evd = Evd.empty in let cstrs = Utils.get_ind_constrs ind in if cstrs = [] then 10 else 10 + (List.fold_left (fun acc x -> acc + (hyp_cost evd (EConstr.of_constr x))) 0 cstrs) / List.length cstrs end let constrs_nsubgoals = memoize_ind begin fun ind -> let evd = Evd.empty in let cstrs = Utils.get_ind_constrs ind in List.fold_left (fun acc x -> max acc (hyp_nsubgoals evd (EConstr.of_constr x))) 0 cstrs end let has_arg_dep evd lst = let open Constr in let open EConstr in Array.exists (fun h -> match kind evd h with | App _ | Const _ | Construct _ -> true | _ -> false) lst let eval_ind_inversion = memoize_ind begin fun ind -> let evd = Evd.empty in let ctrs = Utils.get_ind_constrs ind in let num_ctrs = List.length ctrs in let num_deps = List.length (List.filter begin fun t -> match Utils.destruct_prod evd (EConstr.of_constr t) with | (_, _, args) -> not (has_arg_dep evd args) end ctrs) in let num_deps = if num_deps = num_ctrs then num_deps - 1 else num_deps in (num_ctrs, num_deps) end let create_case_actions opts evd t acc = Utils.fold_constr_shallow begin fun acc t -> let open Constr in let open EConstr in match kind evd t with | Case (ci, _, _, _, _, c, _) when in_sopt_list_ind opts.s_hints !case_split_hints ci.ci_ind opts.s_case_splits -> let num_ctrs = Utils.get_ind_nconstrs ci.ci_ind in (40 + num_ctrs * 5, num_ctrs, ActDestruct c) :: acc | _ -> acc end acc evd t let create_hyp_actions opts evd ghead0 ghead (id, hyp, cost, num_subgoals, (prods, head0, head, args)) = let acts = if Utils.is_False evd head && prods = [] then [(0, 1, ActInvert id)] else if EConstr.eq_constr evd head ghead || EConstr.eq_constr evd head0 ghead0 || EConstr.eq_constr evd head0 ghead then [(cost, num_subgoals, ActApply id)] else let open Constr in let open EConstr in match kind evd head with | Rel _ -> [(cost + 40, num_subgoals, ActApply id)] | _ -> [] in if (opts.s_directed_rewriting || opts.s_undirected_rewriting) && is_equality evd head && not (is_coercion evd head0) then (* using "with_equality" here slows things down considerably *) let args = Array.to_list args in match Hhlib.drop (List.length args - 2) args with | [t1; t2] -> (* TODO: Always do undirected rewriting? *) if opts.s_directed_rewriting then if Lpo.lpo evd t1 t2 then (cost + 5, num_subgoals, ActRewriteLR id) :: acts else if Lpo.lpo evd t2 t1 then (cost + 5, num_subgoals, ActRewriteRL id) :: acts else if opts.s_undirected_rewriting then (cost - num_subgoals * 5, 1, ActRewrite id) :: acts else acts else if opts.s_undirected_rewriting then (cost - num_subgoals * 5, 1, ActRewrite id) :: acts else acts | _ -> acts else acts let create_extra_hyp_actions opts evd (id, hyp, cost, num_subgoals, (prods, head0, head, args)) = let acts = let open Constr in let open EConstr in match kind evd head with | Ind (ind, _) when is_inversion opts evd ind args -> let (num_ctrs, num_deps) = eval_ind_inversion ind in let b_arg_dep = num_ctrs <= 1 || has_arg_dep evd args in [(cost + 40 + if b_arg_dep then num_deps * 10 else num_ctrs * 10), (if b_arg_dep then num_subgoals + max num_deps 1 else num_subgoals + num_ctrs), ActInvert id] | _ -> [] in if not opts.s_eager_case_splitting && opts.s_case_splits <> SNone then create_case_actions opts evd hyp acts else acts let create_case_unfolding_actions opts evd goal hyps = if opts.s_aggressive_unfolding then [] else let create lst = List.fold_left begin fun acc c -> let cost = case_unfold_cost c in if cost >= 0 then (cost, 1, ActCaseUnfold c) :: acc else acc end [] lst in match opts.s_unfolding with | SSome lst -> if opts.s_hints then create (lazyget unfolding_hints @ lst) else create lst | SAll -> create (get_consts evd (goal :: List.map (fun (_, x, _, _, _) -> x) hyps)) | SNone -> [] let create_extra_actions opts evd goal hyps = let actions = List.concat (List.map (create_extra_hyp_actions opts evd) hyps) in let actions = create_case_unfolding_actions opts evd goal hyps @ actions in let actions = if not opts.s_eager_case_splitting && opts.s_case_splits <> SNone then create_case_actions opts evd goal actions else actions in let actions = if opts.s_eager_reducing || not opts.s_reducing then actions else (80, 1, ActReduce) :: actions in actions let create_hint_actions bases evd goal gl = let env = Proofview.Goal.env gl in let secvars = Auto.compute_secvars gl in let hints = List.concat (List.map (fun db -> Utils.find_hints db secvars env evd goal) bases) in List.map begin fun h -> let p = Utils.hint_priority h in (p * 10 + 10, p, ActHint h) end hints (* result: (cost, num_subgoals, action) list *) let create_actions extra opts evd goal hyps gl = let actions = if extra then create_extra_actions opts evd goal hyps else [] in let actions = if opts.s_hint_bases <> [] then create_hint_actions opts.s_hint_bases evd goal gl @ actions else actions in let actions = (25, 0, ActSolve) :: actions in let actions = let open Constr in let open EConstr in match kind evd goal with | Prod _ -> (30, 1, ActIntro) :: actions | _ -> actions in let (_, ghead0, ghead, gargs) = Utils.destruct_prod_red evd goal in let actions = let open Constr in let open EConstr in match kind evd ghead with | Ind (ind, _) when in_sopt_list_ind opts.s_hints (lazyget constructor_hints) ind opts.s_constructors -> (constrs_cost ind, constrs_nsubgoals ind, ActConstructor) :: actions | _ -> actions in let actions = with_equality evd ghead0 gargs actions begin fun t1 t2 -> let open Constr in let open EConstr in match kind evd t1, kind evd t2 with | (App (head1, args1), App (head2, args2)) when eq_constr evd head1 head2 && Array.length args1 = Array.length args2 -> let len = Array.length args1 in (len * 10, len, ActFEqual) :: actions | _ -> actions end in let actions = let open Constr in let open EConstr in match kind evd ghead0 with | Const (c, _) when in_sopt_list_const opts.s_hints (lazyget unfolding_hints) c opts.s_unfolding -> (60, 1, ActUnfold c) :: actions | _ -> actions in let actions = List.concat (List.map (create_hyp_actions opts evd ghead0 ghead) hyps) @ actions in List.stable_sort (fun (x, _, _) (y, _, _) -> Stdlib.compare x y) actions (*****************************************************************************************) type tactics = { t_finish : unit Proofview.tactic; t_simplify : unit Proofview.tactic; t_simplify_concl : unit Proofview.tactic; t_simple_splitting : unit Proofview.tactic; t_case_splitting : unit Proofview.tactic; t_unfolding : unit Proofview.tactic; t_reduce_concl : unit Proofview.tactic; t_subst_simpl : unit Proofview.tactic; b_sapply_initialised : bool; } let create_tactics opts = { t_finish = Tacticals.tclSOLVE [ leaf_tac opts; opts.s_solve_tac ]; t_simplify = simplify opts; t_simplify_concl = simplify_concl opts; t_simple_splitting = simple_splitting opts; t_case_splitting = case_splitting false opts; t_unfolding = unfolding opts; t_reduce_concl = reduce_concl opts; t_subst_simpl = subst_simpl opts; b_sapply_initialised = false; } (*****************************************************************************************) let rec search extra tacs opts n rtrace visited = if n = 0 then Tacticals.tclSOLVE [ tacs.t_finish; opts.s_solve_tac ] else Proofview.Goal.enter begin fun gl -> let goal = Proofview.Goal.concl gl in let evd = Proofview.Goal.sigma gl in let open Constr in let open EConstr in if mem_constr evd goal visited then fail_tac () else match kind evd goal with | Prod (_, h, f) when not (Utils.is_atom evd h) || not (Utils.is_False evd f) -> intros tacs opts n | _ -> if is_simple_split opts evd goal then tacs.t_simple_splitting <*> search extra tacs opts n rtrace (goal :: visited) else if opts.s_eager_case_splitting && is_case_split opts evd goal then Tacticals.tclIFCATCH (Tacticals.tclPROGRESS tacs.t_case_splitting) (fun () -> start_search tacs opts n) (fun () -> run_actions extra tacs opts n rtrace visited evd goal gl) else run_actions extra tacs opts n rtrace visited evd goal gl end and start_search tacs opts n = tacs.t_unfolding <*> tacs.t_simplify <*> if opts.s_sapply && not tacs.b_sapply_initialised then Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in let sapp = List.exists begin fun (_, hyp) -> let (_, head, args) = Utils.destruct_prod evd hyp in is_unorientable_equality evd head args end (Utils.get_hyps gl) in search true tacs { opts with s_sapply = sapp } n [] [] end else search true tacs opts n [] [] and intros tacs opts n = tacs.t_reduce_concl <*> intros_until_atom_tac () <*> opt opts.s_simpl_sigma (simpl_sigma_tac ()) <*> start_search tacs opts n and run_actions extra tacs opts n rtrace visited evd goal gl = let hyps = List.map (eval_hyp evd) (Utils.get_hyps gl) in let actions = create_actions extra opts evd goal hyps gl in match actions with | [] -> tacs.t_finish | (cost, _, _) :: _ when not opts.s_depth_cost_model && cost > n -> tacs.t_finish | _ -> apply_actions tacs opts n actions rtrace (goal :: visited) and apply_actions tacs opts n actions rtrace visited = let branch = if opts.s_exhaustive then Proofview.tclOR else Proofview.tclORELSE in let cont tac acts = branch tac (fun _ -> apply_actions tacs opts n acts rtrace visited) in let continue n tac acts = cont (Proofview.tclBIND tac (fun _ -> search false tacs opts n rtrace visited)) acts in let final_tac = if not opts.s_depth_cost_model && n < 25 then tacs.t_finish else fail_tac () in let apply id = if opts.s_sapply then sapply_tac id else Tactics.Simple.eapply (EConstr.mkVar id) in match actions with | (cost, branching, act) :: acts -> if not opts.s_depth_cost_model && cost > n then final_tac else begin let n' = if opts.s_depth_cost_model then n - 1 else (n - cost) / max branching 1 in match act with | ActApply id -> continue n' (apply id) acts | ActRewriteLR id -> continue n' (erewrite (not opts.s_eager_rewriting) true id <*> tacs.t_simplify_concl) acts | ActRewriteRL id -> continue n' (erewrite (not opts.s_eager_rewriting) false id <*> tacs.t_simplify_concl) acts | ActRewrite id -> if List.memq id rtrace then apply_actions tacs opts n acts rtrace visited else cont (Proofview.tclBIND (srewrite_tac id) (fun _ -> tacs.t_simplify_concl <*> search false tacs opts n (id :: rtrace) visited)) acts | ActInvert id -> cont (sinvert opts id <*> start_search tacs opts n') acts | ActUnfold c -> continue n' (Tacticals.tclPROGRESS (unfold c) <*> tacs.t_simplify_concl) acts | ActCaseUnfold c -> cont (Proofview.tclBIND (Tacticals.tclPROGRESS (fullunfold c)) (fun _ -> start_search tacs opts n')) acts | ActDestruct t -> cont (sdestruct opts t <*> start_search tacs opts n') acts | ActHint h -> continue n' (Tacticals.tclPROGRESS (Utils.hint_tactic h (List.hd visited)) <*> tacs.t_simplify_concl) acts | ActSolve -> cont opts.s_solve_tac acts | ActConstructor -> cont (Tactics.any_constructor true (Some (tacs.t_simplify_concl <*> search false tacs opts n' rtrace visited))) acts | ActIntro -> cont (Tactics.intros <*> tacs.t_subst_simpl <*> start_search tacs opts n') acts | ActReduce -> cont (Proofview.tclBIND (Tacticals.tclPROGRESS (red_in_all_tac ())) (fun _ -> start_search tacs opts n')) acts | ActFEqual -> continue n' (f_equal_tac ()) acts end | [] -> final_tac (*****************************************************************************************) let sinit opts = unfold_local_defs_tac () <*> opt opts.s_reflect (bool_reflect_tac ()) <*> fullunfolding opts <*> unfolding opts <*> subst_simpl opts let sintuition opts = unfold_local_defs_tac () <*> fullunfolding opts <*> Tactics.intros <*> opt opts.s_reflect (bool_reflect_tac ()) <*> simp_hyps_tac () <*> subst_simpl opts <*> ssimpl_tac opts <*> Tacticals.tclREPEAT (Tacticals.tclPROGRESS (Tactics.intros <*> simp_hyps_tac () <*> subst_simpl opts) <*> ssimpl_tac opts) let ssimpl opts = let tac1 = Tactics.intros <*> unfolding opts <*> sintuition opts <*> subst_simpl opts <*> simp_hyps_tac () <*> opt opts.s_forwarding (with_reduction opts (forwarding_tac ()) (forwarding_nored_tac ())) <*> subst_simpl opts and tac2 = Tactics.intros <*> unfolding opts <*> opt opts.s_forwarding (with_reduction opts (forwarding_tac ()) (forwarding_nored_tac ())) <*> subst_simpl opts in let opts2 = { opts with s_simpl_tac = opts.s_ssimpl_tac; s_simpl_nolia_tac = opts.s_ssimpl_nolia_tac } in unfold_local_defs_tac () <*> fullunfolding opts <*> opt opts.s_reflect (bool_reflect_tac ()) <*> tac1 <*> (simplify opts2 <~> tac2) let qsimpl opts = let tac = sintuition opts <~> (opt opts.s_reflect (bnat_reflect_tac ()) <*> opt opts.s_reflect (bool_reflect_tac ())) <~> autorewriting true opts <~> (simple_splitting opts <*> opt opts.s_eager_case_splitting (case_splitting true opts)) <~> opt opts.s_simpl_sigma (simpl_sigma_tac ()) <~> opt opts.s_simple_inverting (simple_inverting opts) in Tactics.intros <*> unfold_local_defs_tac () <*> fullunfolding opts <*> opt opts.s_reflect (bool_reflect_tac ()) <*> unfolding opts <*> tac let sauto opts = sinit opts <*> Tacticals.tclTRY (opts.s_solve_tac) <*> intros (create_tactics opts) opts opts.s_limit let scrush opts = sinit opts <*> ssimpl opts <*> sauto opts let fcrush opts = sinit opts <*> qsimpl opts <*> qforwarding_tac () <*> qsimpl opts <*> instering_tac () <*> qsimpl opts <*> sauto opts let ecrush opts = sinit opts <*> qsimpl opts <*> qforwarding_tac () <*> einstering_tac () <*> esimp_hyps_tac () <*> qsimpl opts <*> sauto opts let sblast opts = sinit opts <*> Tacticals.tclSOLVE [Tacticals.tclREPEAT (ssimpl opts <*> instering_tac ())] let qblast opts = sinit opts <*> Tacticals.tclSOLVE [Tacticals.tclREPEAT (qsimpl opts <*> qforwarding_tac () <*> instering_tac ())] let scongruence opts = sinit opts <*> Tactics.intros <*> congr_tac () let sfirstorder opts = sinit opts <*> if opts.s_lia then Utils.ltac_apply "Tactics.firstorder_tac" [] else Utils.ltac_apply "Tactics.firstorder_nolia_tac" [] let strivial opts = sinit opts <*> if opts.s_lia then Utils.ltac_apply "Tactics.isolve" [] else Utils.ltac_apply "Tactics.isolve_nolia" [] let print_actions opts = Proofview.Goal.enter begin fun gl -> let goal = Proofview.Goal.concl gl in let evd = Proofview.Goal.sigma gl in let hyps = List.map (eval_hyp evd) (Utils.get_hyps gl) in let actions = create_actions true opts evd goal hyps gl in print_search_actions actions; Tacticals.tclIDTAC end let unshelve tac = Proofview.with_shelf tac >>= begin fun (shelf, _) -> Proofview.Unsafe.tclNEWGOALS (List.map Proofview.with_empty_state shelf) end let usolve tac = unshelve tac <*> dsolve_tac () coqhammer-1.3.2-8.20/src/tactics/sauto.mli000066400000000000000000000053261471571225200201510ustar00rootroot00000000000000(* sauto -- interface *) open Names type 'a soption = SNone | SAll | SSome of 'a type s_opts = { s_exhaustive : bool; s_hints : bool; s_leaf_tac : unit Proofview.tactic; s_leaf_nolia_tac : unit Proofview.tactic; s_solve_tac : unit Proofview.tactic; s_simpl_tac : unit Proofview.tactic; s_simpl_nolia_tac : unit Proofview.tactic; s_ssimpl_tac : unit Proofview.tactic; s_ssimpl_nolia_tac : unit Proofview.tactic; s_unfolding : Constant.t list soption; s_always_unfold : Constant.t list soption; s_constructors : inductive list soption; s_simple_splits : inductive list soption; s_case_splits : inductive list soption; s_inversions : inductive list soption; s_rew_bases : string list; s_hint_bases : Hints.hint_db list; s_reflect : bool; s_eager_case_splitting : bool; s_eager_reducing : bool; s_eager_rewriting : bool; s_eager_inverting : bool; s_simple_inverting : bool; s_forwarding : bool; s_reducing : bool; s_directed_rewriting : bool; s_undirected_rewriting : bool; s_aggressive_unfolding : bool; s_sapply : bool; s_depth_cost_model : bool; s_limit : int; s_simpl_sigma : bool; s_lia : bool; s_dep : bool; s_genproofs : bool; } val default_s_opts : unit -> s_opts val hauto_s_opts : unit -> s_opts val qauto_s_opts : unit -> s_opts val set_dep_opts : bool -> s_opts -> s_opts val set_eager_opts : bool -> s_opts -> s_opts val set_quick_opts : bool -> s_opts -> s_opts val set_brefl_opts : bool -> s_opts -> s_opts val set_rew_opts : bool -> s_opts -> s_opts val simple_splitting : s_opts -> unit Proofview.tactic val eager_inverting : s_opts -> unit Proofview.tactic val sunfold : bool (* aggressive? *) -> Constant.t -> unit Proofview.tactic val sunfolding : bool (* aggressive? *) -> unit Proofview.tactic val sinit : s_opts -> unit Proofview.tactic val sauto : s_opts -> unit Proofview.tactic val sintuition : s_opts -> unit Proofview.tactic val ssimpl : s_opts -> unit Proofview.tactic val qsimpl : s_opts -> unit Proofview.tactic val scrush : s_opts -> unit Proofview.tactic val fcrush : s_opts -> unit Proofview.tactic val ecrush : s_opts -> unit Proofview.tactic val sblast : s_opts -> unit Proofview.tactic val qblast : s_opts -> unit Proofview.tactic val scongruence : s_opts -> unit Proofview.tactic val sfirstorder : s_opts -> unit Proofview.tactic val strivial : s_opts -> unit Proofview.tactic val add_unfold_hint : Constant.t -> unit val add_ctrs_hint : inductive -> unit val add_simple_split_hint : inductive -> unit val add_case_split_hint : inductive -> unit val add_inversion_hint : inductive -> unit val print_actions : s_opts -> unit Proofview.tactic val unshelve : 'a Proofview.tactic -> unit Proofview.tactic val usolve : 'a Proofview.tactic -> unit Proofview.tactic coqhammer-1.3.2-8.20/src/tactics/tacbest.ml000066400000000000000000000413201471571225200202640ustar00rootroot00000000000000open Hammer_lib open Hammer_errors open Sauto open Tacopts let trivial_tacs_batch lst = [ (usolve (interp_opts (default_s_opts ()) lst sfirstorder), "sfirstorder"); (usolve (interp_opts (default_s_opts ()) lst scongruence), "scongruence") ] let hbest_tacs lst = [ (usolve (interp_opts (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) lst sauto), "hauto lq: on"); (usolve (interp_opts (set_quick_opts true (hauto_s_opts ())) lst sauto), "hauto q: on"); (usolve (interp_opts (set_eager_opts false (hauto_s_opts ())) lst sauto), "hauto l: on"); (usolve (interp_opts (hauto_s_opts ()) lst sauto), "hauto"); (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (set_eager_opts false (hauto_s_opts ())))) lst sauto), "hauto lqb: on"); (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (hauto_s_opts ()))) lst sauto), "hauto qb: on"); (usolve (interp_opts (set_brefl_opts true (set_eager_opts false (hauto_s_opts ()))) lst sauto), "hauto lb: on"); (usolve (interp_opts (set_brefl_opts true (hauto_s_opts ())) lst sauto), "hauto b: on") ] let sbest_tacs lst = [ (usolve (interp_opts (set_quick_opts true (set_eager_opts false (default_s_opts ()))) lst sauto), "sauto lq: on"); (usolve (interp_opts (set_quick_opts true (default_s_opts ())) lst sauto), "sauto q: on"); (usolve (interp_opts (set_eager_opts false (default_s_opts ())) lst sauto), "sauto l: on"); (usolve (interp_opts (default_s_opts ()) lst sauto), "sauto"); (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (set_eager_opts false (default_s_opts ())))) lst sauto), "sauto lqb: on"); (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (default_s_opts ()))) lst sauto), "sauto qb: on"); (usolve (interp_opts (set_brefl_opts true (set_eager_opts false (default_s_opts ()))) lst sauto), "sauto lb: on"); (usolve (interp_opts (set_brefl_opts true (default_s_opts ())) lst sauto), "sauto b: on") ] let best_tacs_batch_a lst = [ (usolve (interp_opts (default_s_opts ()) lst sfirstorder), "sfirstorder"); (usolve (interp_opts (default_s_opts ()) lst scongruence), "scongruence"); (usolve (interp_opts (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) lst sauto), "hauto lq: on"); (usolve (interp_opts (set_quick_opts true (hauto_s_opts ())) lst sauto), "hauto q: on"); (usolve (interp_opts (set_eager_opts false (hauto_s_opts ())) lst sauto), "hauto l: on"); (usolve (interp_opts (set_quick_opts true (set_eager_opts false (default_s_opts ()))) lst sauto), "sauto lq: on"); (usolve (interp_opts (set_eager_opts false (qauto_s_opts ())) lst sauto), "qauto l: on"); (usolve (interp_opts (set_rew_opts false (set_quick_opts true (set_eager_opts false (hauto_s_opts ())))) lst sauto), "hauto lq: on rew: off"); (usolve (interp_opts (set_rew_opts false (set_quick_opts true (set_eager_opts false (default_s_opts ())))) lst sauto), "sauto lq: on rew: off") ] let best_tacs_batch_b lst = [ (usolve (interp_opts ({ (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) with s_directed_rewriting = false }) lst sauto), "hauto lq: on drew: off"); (usolve (interp_opts { (set_quick_opts true (hauto_s_opts ())) with s_directed_rewriting = false} lst sauto), "hauto q: on drew: off"); (usolve (interp_opts ({ (set_eager_opts false (hauto_s_opts ())) with s_directed_rewriting = false }) lst sauto), "hauto l: on drew: off"); (usolve (interp_opts (set_quick_opts true (hauto_s_opts ())) lst sauto), "hauto"); (usolve (interp_opts (set_quick_opts true (default_s_opts ())) lst sauto), "sauto q: on"); (usolve (interp_opts (set_eager_opts false (default_s_opts ())) lst sauto), "sauto l: on"); (usolve (interp_opts (default_s_opts ()) lst sauto), "sauto"); (usolve (interp_opts { (hauto_s_opts ()) with s_directed_rewriting = false } lst sauto), "hauto drew: off") ] let best_tacs_batch_c lst = [ (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (set_eager_opts false (hauto_s_opts ())))) lst sauto), "hauto lqb: on"); (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (hauto_s_opts ()))) lst sauto), "hauto qb: on"); (usolve (interp_opts (set_brefl_opts true (set_eager_opts false (hauto_s_opts ()))) lst sauto), "hauto lb: on"); (usolve (interp_opts (set_brefl_opts true (hauto_s_opts ())) lst sauto), "hauto b: on"); (usolve (interp_opts { (set_brefl_opts true (set_quick_opts true (set_eager_opts false (hauto_s_opts ())))) with s_directed_rewriting = false } lst sauto), "hauto lqb: on drew: off"); (usolve (interp_opts { (set_brefl_opts true (set_quick_opts true (hauto_s_opts ()))) with s_directed_rewriting = false } lst sauto), "hauto qb: on drew: off"); (usolve (interp_opts { (set_brefl_opts true (set_eager_opts false (hauto_s_opts ()))) with s_directed_rewriting = false } lst sauto), "hauto lb: on drew: off"); (usolve (interp_opts { (set_brefl_opts true (hauto_s_opts ())) with s_directed_rewriting = false } lst sauto), "hauto b: on drew: off") ] let best_tacs_batch_1 lst = [ (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (set_eager_opts false (default_s_opts ())))) lst sauto), "sauto lqb: on"); (usolve (interp_opts (set_brefl_opts true (set_quick_opts true (default_s_opts ()))) lst sauto), "sauto qb: on"); (usolve (interp_opts (set_brefl_opts true (set_eager_opts false (default_s_opts ()))) lst sauto), "sauto lb: on"); (usolve (interp_opts (set_brefl_opts true (default_s_opts ())) lst sauto), "sauto b: on"); (usolve (interp_opts ({ (set_quick_opts true (set_eager_opts false (default_s_opts ()))) with s_directed_rewriting = false }) lst sauto), "sauto lq: on drew: off"); (usolve (interp_opts { (set_quick_opts true (default_s_opts ())) with s_directed_rewriting = false} lst sauto), "sauto q: on drew: off"); (usolve (interp_opts ({ (set_eager_opts false (default_s_opts ())) with s_directed_rewriting = false }) lst sauto), "sauto l: on drew: off"); (usolve (interp_opts { (default_s_opts ()) with s_directed_rewriting = false } lst sauto), "sauto drew: off") ] let best_tacs_batch_2 lst = [ (usolve (interp_opts (qauto_s_opts ()) lst sauto), "qauto"); (usolve (interp_opts (hauto_s_opts ()) lst fcrush), "hfcrush"); (usolve (interp_opts (hauto_s_opts ()) lst ecrush), "hecrush"); (usolve (interp_opts (default_s_opts ()) lst sblast), "qblast"); (usolve (interp_opts (default_s_opts ()) lst sblast), "sblast"); (usolve (interp_opts (default_s_opts ()) lst fcrush), "fcrush"); (usolve (interp_opts (default_s_opts ()) lst ecrush), "ecrush"); (usolve (interp_opts (default_s_opts ()) lst scrush), "scrush") ] let best_tacs_batch_3 lst = [ (usolve (interp_opts { (qauto_s_opts ()) with s_directed_rewriting = false } lst sauto), "qauto drew: off"); (usolve (interp_opts { (hauto_s_opts ()) with s_directed_rewriting = false } lst fcrush), "hfcrush drew: off"); (usolve (interp_opts { (hauto_s_opts ()) with s_directed_rewriting = false } lst ecrush), "hecrush drew: off"); (usolve (interp_opts { (default_s_opts ()) with s_directed_rewriting = false } lst sblast), "qblast drew: off"); (usolve (interp_opts { (default_s_opts ()) with s_directed_rewriting = false } lst sblast), "sblast drew: off"); (usolve (interp_opts { (default_s_opts ()) with s_directed_rewriting = false } lst fcrush), "fcrush drew: off"); (usolve (interp_opts { (default_s_opts ()) with s_directed_rewriting = false } lst ecrush), "ecrush drew: off"); (usolve (interp_opts { (default_s_opts ()) with s_directed_rewriting = false } lst scrush), "scrush drew: off") ] let best_tacs_batch_4 lst = [ (usolve (interp_opts { (set_brefl_opts true (set_quick_opts true (set_eager_opts false (default_s_opts ())))) with s_directed_rewriting = false } lst sauto), "sauto lqb: on drew: off"); (usolve (interp_opts { (set_brefl_opts true (set_quick_opts true (default_s_opts ()))) with s_directed_rewriting = false } lst sauto), "sauto qb: on drew: off"); (usolve (interp_opts { (set_brefl_opts true (set_eager_opts false (default_s_opts ()))) with s_directed_rewriting = false } lst sauto), "sauto lb: on drew: off"); (usolve (interp_opts { (set_brefl_opts true (default_s_opts ())) with s_directed_rewriting = false } lst sauto), "sauto b: on drew: off"); (usolve (interp_opts (set_dep_opts true (set_quick_opts true (set_eager_opts false (hauto_s_opts ())))) lst sauto), "hauto lq: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_quick_opts true (hauto_s_opts ()))) lst sauto), "hauto q: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_eager_opts false (hauto_s_opts ()))) lst sauto), "hauto l: on dep: on"); (usolve (interp_opts (set_dep_opts true (hauto_s_opts ())) lst sauto), "hauto dep: on") ] let best_tacs_batch_5 lst = [ (usolve (interp_opts (set_dep_opts true (set_quick_opts true (set_eager_opts false (default_s_opts ())))) lst sauto), "sauto lq: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_quick_opts true (default_s_opts ()))) lst sauto), "sauto q: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_eager_opts false (default_s_opts ()))) lst sauto), "sauto l: on dep: on"); (usolve (interp_opts (set_dep_opts true (default_s_opts ())) lst sauto), "sauto dep: on"); (usolve (interp_opts (set_dep_opts true (set_brefl_opts true (set_quick_opts true (set_eager_opts false (default_s_opts ()))))) lst sauto), "sauto lqb: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_brefl_opts true (set_quick_opts true (default_s_opts ())))) lst sauto), "sauto qb: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_brefl_opts true (set_eager_opts false (default_s_opts ())))) lst sauto), "sauto lb: on dep: on"); (usolve (interp_opts (set_dep_opts true (set_brefl_opts true (default_s_opts ()))) lst sauto), "sauto b: on dep: on") ] let best_tacs lst = [ (usolve (interp_opts (hauto_s_opts ()) lst sfirstorder), "sfirstorder"); (usolve (interp_opts (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) lst sauto), "hauto lq: on"); (usolve (interp_opts (set_quick_opts true (hauto_s_opts ())) lst sauto), "hauto"); (usolve (interp_opts (set_quick_opts true (set_eager_opts false (default_s_opts ()))) lst sauto), "sauto lq: on"); (usolve (interp_opts (set_quick_opts true (default_s_opts ())) lst sauto), "sauto q: on"); (usolve (interp_opts (default_s_opts ()) lst sauto), "sauto"); (usolve (interp_opts ({ (set_quick_opts true (set_eager_opts false (hauto_s_opts ()))) with s_directed_rewriting = false }) lst sauto), "hauto lq: on drew: off"); (usolve (interp_opts ({ (set_quick_opts true (set_eager_opts false (default_s_opts ()))) with s_directed_rewriting = false }) lst sauto), "sauto lq: on drew: off"); (usolve (interp_opts (set_brefl_opts true (hauto_s_opts ())) lst sauto), "hauto b: on"); (usolve (interp_opts (default_s_opts ()) lst fcrush), "fcrush") ] let best_tactics lst = [best_tacs_batch_a lst; best_tacs_batch_b lst; best_tacs_batch_c lst; best_tacs_batch_1 lst; best_tacs_batch_2 lst; best_tacs_batch_3 lst; best_tacs_batch_4 lst; best_tacs_batch_5 lst] let hbest_tactics lst = [trivial_tacs_batch lst @ hbest_tacs lst] let sbest_tactics lst = [trivial_tacs_batch lst @ sbest_tacs lst] let hammer_pretactics () = best_tacs [] let run_best limit tacs (lst : sopt_t list) (f_success : string -> unit Proofview.tactic -> unit Proofview.tactic) (f_failure : unit -> unit Proofview.tactic) : unit Proofview.tactic = try_tactic begin fun () -> Hhpartac.partac limit (List.map fst tacs) begin fun k tac -> if k >= 0 then let tacname = snd (List.nth tacs k) in Proofview.Goal.enter begin fun gl -> let evd = Proofview.Goal.sigma gl in f_success (tacname ^ " " ^ string_of_sopt_list evd lst) tac end else f_failure () end end let try_best batches limit lst msg_success msg_failure = let rec hlp tacs = match tacs with | h :: t -> run_best limit h lst begin fun str tac -> Feedback.msg_info (Pp.str (msg_success ^ str)); tac end (fun () -> hlp t) | [] -> Tacticals.tclZEROMSG (Pp.str msg_failure) in hlp batches let default_best_limit = 1 let find_best_tactic batches l name = let limit = List.fold_left (fun acc x -> match x with SOTimeout n -> n | _ -> acc) default_best_limit l in let lst = List.filter (fun x -> match x with SOTimeout _ -> false | _ -> true) l in try_tactic (fun () -> try_best batches limit lst ("Replace the `" ^ name ^ "` tactic with:\n\t") ("The `" ^ name ^ "` tactic failed. You may try increasing the time limit with the `time:` option (default: 1s), or setting the `depth:` option. See https://coqhammer.github.io for more information.")) coqhammer-1.3.2-8.20/src/tactics/tacbest.mli000066400000000000000000000015241471571225200204370ustar00rootroot00000000000000open Tacopts val best_tactics : sopt_t list -> (unit Proofview.tactic * string) list list val hbest_tactics : sopt_t list -> (unit Proofview.tactic * string) list list val sbest_tactics : sopt_t list -> (unit Proofview.tactic * string) list list val hammer_pretactics : unit -> (unit Proofview.tactic * string) list val run_best : int (* time limit *) -> (unit Proofview.tactic * string) list (* tactic list *) -> sopt_t list (* sauto options *) -> (string -> unit Proofview.tactic -> unit Proofview.tactic) (* success continuation *) -> (unit -> unit Proofview.tactic) (* failure continuation *) -> unit Proofview.tactic val find_best_tactic : (unit Proofview.tactic * string) list list -> (* tactic batches to try *) sopt_t list -> (* sauto options *) string -> (* tactic name ("best", "hammer", ...) *) unit Proofview.tactic coqhammer-1.3.2-8.20/src/tactics/tacopts.ml000066400000000000000000000325771471571225200203320ustar00rootroot00000000000000(* sauto tactic options - implementation *) open Ltac_plugin open Proofview.Notations open Hammer_lib open Hammer_errors open Sauto module Utils = Hhutils type sopt_t = SONop | SOUse of Constrexpr.constr_expr list | SOGen of Constrexpr.constr_expr list | SOUnfold of Libnames.qualid list | SOUnfoldAll | SOUnfoldNone | SOAlwaysUnfold of Libnames.qualid list | SOAlwaysUnfoldAll | SOAlwaysUnfoldNone | SOInv of Libnames.qualid list | SOInvAll | SOInvNone | SOCtrs of Libnames.qualid list | SOCtrsAll | SOCtrsNone | SOCaseSplit of Libnames.qualid list | SOCaseSplitAll | SOCaseSplitNone | SOSimpleSplit of Libnames.qualid list | SOSimpleSplitAll | SOSimpleSplitNone | SOBases of string list | SOBasesAdd of string list | SOBasesAll | SORewBases of string list | SORewBasesAdd of string list | SOHintBases of string list | SOHintBasesAdd of string list | SOHintBasesAll | SOFinish of Tacexpr.raw_tactic_expr | SOFinal of Tacexpr.raw_tactic_expr | SOSolve of Tacexpr.raw_tactic_expr | SOSimp of Tacexpr.raw_tactic_expr | SOSSimp of Tacexpr.raw_tactic_expr | SOSolveAdd of Tacexpr.raw_tactic_expr | SOSimpAdd of Tacexpr.raw_tactic_expr | SOSSimpAdd of Tacexpr.raw_tactic_expr | SOForward of bool | SOEagerCaseSplit of bool | SOSimpleInvert of bool | SOEagerInvert of bool | SOEagerReduce of bool | SOEagerRewrite of bool | SODirectedRewrite of bool | SOUndirectedRewrite of bool | SORewrite of bool | SOReflect of bool | SOReflectRaw of bool | SOReduce of bool | SOSapply of bool | SOLimit of int | SODepth of int | SOTimeout of int | SOExhaustive of bool | SOLia of bool | SOSig of bool | SOPrf of bool | SODep of bool | SODepRaw of bool | SOEager of bool | SOQuick of bool let string_of_bopt b = if b then "on" else "off" let string_of_strlist lst = match lst with | [] -> "-" | _ -> Hhlib.sfold (fun x -> x) ", " lst let string_of_qualid_list lst = match lst with | [] -> "-" | _ -> Hhlib.sfold (fun q -> Pp.string_of_ppcmds (Libnames.pr_qualid q)) ", " lst let string_of_tactic evd tac = Pp.string_of_ppcmds (Pptactic.pr_raw_tactic (Global.env ()) evd tac) let string_of_sopt evd opt = match opt with | SONop -> "" | SOUse lst -> "use: " ^ Hhlib.sfold (Hhutils.constr_expr_to_string evd) ", " lst | SOGen lst -> "gen: " ^ Hhlib.sfold (Hhutils.constr_expr_to_string evd) ", " lst | SOUnfold lst -> "unfold: " ^ string_of_qualid_list lst | SOUnfoldAll -> "unfold: *" | SOUnfoldNone -> "unfold: -" | SOAlwaysUnfold lst -> "unfold!: " ^ string_of_qualid_list lst | SOAlwaysUnfoldAll -> "unfold!: *" | SOAlwaysUnfoldNone -> "unfold!: -" | SOInv lst -> "inv: " ^ string_of_qualid_list lst | SOInvAll -> "inv: *" | SOInvNone -> "inv: never" | SOCtrs lst -> "ctrs: " ^ string_of_qualid_list lst | SOCtrsAll -> "ctrs: *" | SOCtrsNone -> "ctrs: never" | SOCaseSplit lst -> "cases: " ^ string_of_qualid_list lst | SOCaseSplitAll -> "cases: *" | SOCaseSplitNone -> "cases: never" | SOSimpleSplit lst -> "split: " ^ string_of_qualid_list lst | SOSimpleSplitAll -> "split: *" | SOSimpleSplitNone -> "split: never" | SOBases lst -> "db: " ^ string_of_strlist lst | SOBasesAdd lst -> "db+: " ^ string_of_strlist lst | SOBasesAll -> "db: *" | SORewBases lst -> "rew:db: " ^ string_of_strlist lst | SORewBasesAdd lst -> "rew:db+: " ^ string_of_strlist lst | SOHintBases lst -> "hint:db: " ^ string_of_strlist lst | SOHintBasesAdd lst -> "hint:db+: " ^ string_of_strlist lst | SOHintBasesAll -> "hint:db: *" | SOFinish tac -> "finish: " ^ string_of_tactic evd tac | SOFinal tac -> "final: " ^ string_of_tactic evd tac | SOSolve tac -> "solve: " ^ string_of_tactic evd tac | SOSimp tac -> "simp: " ^ string_of_tactic evd tac | SOSSimp tac -> "ssimp: " ^ string_of_tactic evd tac | SOSolveAdd tac -> "solve+: " ^ string_of_tactic evd tac | SOSimpAdd tac -> "simp+: " ^ string_of_tactic evd tac | SOSSimpAdd tac -> "ssimp+: " ^ string_of_tactic evd tac | SOForward b -> "fwd: " ^ string_of_bopt b | SOEagerCaseSplit b -> "ecases: " ^ string_of_bopt b | SOSimpleInvert b -> "sinv: " ^ string_of_bopt b | SOEagerInvert b -> "einv: " ^ string_of_bopt b | SOEagerReduce b -> "ered: " ^ string_of_bopt b | SOEagerRewrite b -> "erew: " ^ string_of_bopt b | SODirectedRewrite b -> "drew: " ^ string_of_bopt b | SOUndirectedRewrite b -> "urew: " ^ string_of_bopt b | SORewrite b -> "rew: " ^ string_of_bopt b | SOReflect b -> "brefl: " ^ string_of_bopt b | SOReflectRaw b -> "brefl!:" ^ string_of_bopt b | SOReduce b -> "red: " ^ string_of_bopt b | SOSapply b -> "sapp: " ^ string_of_bopt b | SOLimit n -> "limit: " ^ string_of_int n | SODepth d -> "depth: " ^ string_of_int d | SOTimeout n -> "time: " ^ string_of_int n | SOExhaustive b -> "exh: " ^ string_of_bopt b | SOLia b -> "lia: " ^ string_of_bopt b | SOSig b -> "sig: " ^ string_of_bopt b | SOPrf b -> "prf: " ^ string_of_bopt b | SODep b -> "dep: " ^ string_of_bopt b | SODepRaw b -> "dep!: " ^ string_of_bopt b | SOEager b -> "l: " ^ string_of_bopt (not b) | SOQuick b -> "q: " ^ string_of_bopt b let string_of_sopt_list evd lst = List.fold_right (^) (List.map (string_of_sopt evd) (List.filter (fun x -> x <> SONop) lst)) "" let const_of_qualid q = catch_errors (fun () -> Utils.get_const_from_qualid q) (fun _ -> raise (HammerTacticError ("not a constant: " ^ Libnames.string_of_qualid q))) let inductive_of_qualid q = catch_errors (fun () -> Utils.get_inductive_from_qualid q) (fun _ -> raise (HammerTacticError ("not an inductive type: " ^ Libnames.string_of_qualid q))) let exists_rew_db s = catch_errors (fun () -> ignore (Autorewrite.find_rewrites s); true) (fun _ -> false) let exists_hint_db s = catch_errors (fun () -> ignore (Hints.searchtable_map s); true) (fun _ -> false) let partition_hint_bases bases = let (lst1, lst2) = List.partition exists_rew_db bases in (lst1, Hints.make_db_list (List.filter exists_hint_db lst1 @ lst2)) let check_rew_bases = List.iter begin fun s -> if not (exists_rew_db s) then raise (HammerTacticError ("Rewriting base " ^ s ^ " does not exist")) end let sopt_append sc lst2 = match sc with | SSome lst1 -> SSome (lst1 @ lst2) | _ -> SSome lst2 let use_constrs lems = Generalize.generalize lems <*> Tacticals.tclDO (List.length lems) (Proofview.tclORELSE (Tactics.intro_move None Logic.MoveFirst) (fun _ -> Tactics.intro)) let gen_constrs lems = Generalize.generalize lems let interp_use use ret opts lst env sigma = let (sigma, lst) = List.fold_left begin fun (sigma, acc) t -> let (sigma', t') = Utils.intern_constr env sigma t in (sigma', t' :: acc) end (sigma, []) lst in let (lems, ctrs) = List.fold_left begin fun (lems, ctrs) t -> let open Constr in let open EConstr in match kind sigma t with | Ind(ind, _) -> (lems, ind :: ctrs) | _ -> (t :: lems, ctrs) end ([], []) lst in let opts = if ctrs <> [] then { opts with s_constructors = sopt_append opts.s_constructors ctrs } else opts in Tacticals.tclWITHHOLES true (use lems) sigma <*> ret opts let mk_final tac = let sfinal = Libnames.qualid_of_string "Tactics.sfinal" in CAst.make (Tacexpr.TacArg Tacexpr.(TacCall(CAst.make (sfinal, [Tacexpr.Tacexp tac])))) let interp_opt ret opt opts = match opt with | SONop -> ret opts | SOUse lst -> Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in interp_use use_constrs ret opts lst env sigma end | SOGen lst -> Proofview.Goal.enter begin fun gl -> let sigma = Proofview.Goal.sigma gl in let env = Proofview.Goal.env gl in interp_use gen_constrs ret opts lst env sigma end | SOUnfold lst -> let lst = List.map const_of_qualid lst in ret { opts with s_unfolding = sopt_append opts.s_unfolding lst } | SOUnfoldAll -> ret { opts with s_unfolding = SAll } | SOUnfoldNone -> ret { opts with s_unfolding = SNone } | SOAlwaysUnfold lst -> let lst = List.map const_of_qualid lst in ret { opts with s_always_unfold = sopt_append opts.s_always_unfold lst } | SOAlwaysUnfoldAll -> ret { opts with s_always_unfold = SAll } | SOAlwaysUnfoldNone -> ret { opts with s_always_unfold = SNone } | SOInv lst -> let lst = List.map inductive_of_qualid lst in ret { opts with s_inversions = sopt_append opts.s_inversions lst } | SOInvAll -> ret { opts with s_inversions = SAll } | SOInvNone -> ret { opts with s_inversions = SNone } | SOCtrs lst -> let lst = List.map inductive_of_qualid lst in ret { opts with s_constructors = sopt_append opts.s_constructors lst } | SOCtrsAll -> ret { opts with s_constructors = SAll } | SOCtrsNone -> ret { opts with s_constructors = SNone } | SOCaseSplit lst -> let lst = List.map inductive_of_qualid lst in ret { opts with s_case_splits = sopt_append opts.s_case_splits lst } | SOCaseSplitAll -> ret { opts with s_case_splits = SAll } | SOCaseSplitNone -> ret { opts with s_case_splits = SNone } | SOSimpleSplit lst -> let lst = List.map inductive_of_qualid lst in ret { opts with s_simple_splits = sopt_append opts.s_simple_splits lst } | SOSimpleSplitAll -> ret { opts with s_simple_splits = SAll } | SOSimpleSplitNone -> ret { opts with s_simple_splits = SNone } | SOBases lst -> let (lst1, lst2) = partition_hint_bases lst in ret { opts with s_rew_bases = lst1; s_hint_bases = lst2 } | SOBasesAdd lst -> let (lst1, lst2) = partition_hint_bases lst in ret { opts with s_rew_bases = opts.s_rew_bases @ lst1; s_hint_bases = opts.s_hint_bases @ lst2 } | SOBasesAll -> ret { opts with s_hint_bases = Hints.current_pure_db () } | SORewBases lst -> check_rew_bases lst; ret { opts with s_rew_bases = lst } | SORewBasesAdd lst -> check_rew_bases lst; ret { opts with s_rew_bases = opts.s_rew_bases @ lst } | SOHintBases lst -> let hints = Hints.make_db_list lst in ret { opts with s_hint_bases = hints } | SOHintBasesAdd lst -> let hints = Hints.make_db_list lst in ret { opts with s_hint_bases = opts.s_hint_bases @ hints } | SOHintBasesAll -> ret { opts with s_hint_bases = Hints.current_pure_db () } | SOFinish tac -> let tac = Tacticals.tclSOLVE [Tacinterp.interp tac] in ret { opts with s_leaf_tac = tac; s_leaf_nolia_tac = tac } | SOFinal tac -> let tac = Tacticals.tclSOLVE [Tacinterp.interp (mk_final tac)] in ret { opts with s_leaf_tac = tac; s_leaf_nolia_tac = tac } | SOSolve tac -> ret { opts with s_solve_tac = Tacticals.tclSOLVE [Tacinterp.interp tac] } | SOSimp tac -> let tac = Tacinterp.interp tac in ret { opts with s_simpl_tac = tac; s_simpl_nolia_tac = tac } | SOSSimp tac -> let tac = Tacinterp.interp tac in ret { opts with s_ssimpl_tac = tac; s_ssimpl_nolia_tac = tac } | SOSolveAdd tac -> ret { opts with s_solve_tac = Tacticals.tclSOLVE [opts.s_leaf_tac; Tacinterp.interp tac] } | SOSimpAdd tac -> let tac = Tacticals.tclTRY (Tacinterp.interp tac) in ret { opts with s_simpl_tac = opts.s_simpl_tac <*> tac; s_simpl_nolia_tac = opts.s_simpl_nolia_tac <*> tac } | SOSSimpAdd tac -> let tac = Tacticals.tclTRY (Tacinterp.interp tac) in ret { opts with s_ssimpl_tac = opts.s_ssimpl_tac <*> tac; s_ssimpl_nolia_tac = opts.s_ssimpl_nolia_tac <*> tac } | SOForward b -> ret { opts with s_forwarding = b } | SOEagerCaseSplit b -> ret { opts with s_eager_case_splitting = b } | SOSimpleInvert b -> ret { opts with s_simple_inverting = b } | SOEagerInvert b -> ret { opts with s_eager_inverting = b } | SOEagerReduce b -> ret { opts with s_eager_reducing = b } | SOEagerRewrite b -> ret { opts with s_eager_rewriting = b } | SODirectedRewrite b -> ret { opts with s_directed_rewriting = b } | SOUndirectedRewrite b -> ret { opts with s_undirected_rewriting = b } | SORewrite b -> ret (set_rew_opts b opts) | SOReflect b -> ret (set_brefl_opts b opts) | SOReflectRaw b -> ret { opts with s_reflect = b } | SOReduce b -> ret { opts with s_reducing = b } | SOSapply b -> ret { opts with s_sapply = b } | SOLimit n -> ret { opts with s_limit = n; s_depth_cost_model = false } | SODepth n -> ret { opts with s_limit = n; s_depth_cost_model = true } | SOTimeout _ -> ret opts | SOExhaustive b -> ret { opts with s_exhaustive = b } | SOLia b -> ret { opts with s_lia = b } | SOSig b -> ret { opts with s_simpl_sigma = b } | SOPrf b -> ret { opts with s_genproofs = b } | SODep b -> ret (set_dep_opts b opts) | SODepRaw b -> ret { opts with s_dep = b } | SOEager b -> ret (set_eager_opts b opts) | SOQuick b -> ret (set_quick_opts b opts) let interp_opts (opts : s_opts) (lst : sopt_t list) (ret : s_opts -> unit Proofview.tactic) : unit Proofview.tactic = let rec interp lst (opts : s_opts) : unit Proofview.tactic = match lst with | [] -> ret opts | opt :: lst' -> let ret opts = Proofview.tclUNIT opts >>= fun opts -> try_tactic begin fun () -> interp lst' opts end in interp_opt ret opt opts in interp lst opts coqhammer-1.3.2-8.20/src/tactics/tacopts.mli000066400000000000000000000035071471571225200204720ustar00rootroot00000000000000(* sauto tactic options - interface *) open Ltac_plugin open Sauto type sopt_t = SONop | SOUse of Constrexpr.constr_expr list | SOGen of Constrexpr.constr_expr list | SOUnfold of Libnames.qualid list | SOUnfoldAll | SOUnfoldNone | SOAlwaysUnfold of Libnames.qualid list | SOAlwaysUnfoldAll | SOAlwaysUnfoldNone | SOInv of Libnames.qualid list | SOInvAll | SOInvNone | SOCtrs of Libnames.qualid list | SOCtrsAll | SOCtrsNone | SOCaseSplit of Libnames.qualid list | SOCaseSplitAll | SOCaseSplitNone | SOSimpleSplit of Libnames.qualid list | SOSimpleSplitAll | SOSimpleSplitNone | SOBases of string list | SOBasesAdd of string list | SOBasesAll | SORewBases of string list | SORewBasesAdd of string list | SOHintBases of string list | SOHintBasesAdd of string list | SOHintBasesAll | SOFinish of Tacexpr.raw_tactic_expr | SOFinal of Tacexpr.raw_tactic_expr | SOSolve of Tacexpr.raw_tactic_expr | SOSimp of Tacexpr.raw_tactic_expr | SOSSimp of Tacexpr.raw_tactic_expr | SOSolveAdd of Tacexpr.raw_tactic_expr | SOSimpAdd of Tacexpr.raw_tactic_expr | SOSSimpAdd of Tacexpr.raw_tactic_expr | SOForward of bool | SOEagerCaseSplit of bool | SOSimpleInvert of bool | SOEagerInvert of bool | SOEagerReduce of bool | SOEagerRewrite of bool | SODirectedRewrite of bool | SOUndirectedRewrite of bool | SORewrite of bool | SOReflect of bool | SOReflectRaw of bool | SOReduce of bool | SOSapply of bool | SOLimit of int | SODepth of int | SOTimeout of int | SOExhaustive of bool | SOLia of bool | SOSig of bool | SOPrf of bool | SODep of bool | SODepRaw of bool | SOEager of bool | SOQuick of bool val string_of_sopt : Evd.evar_map -> sopt_t -> string val string_of_sopt_list : Evd.evar_map -> sopt_t list -> string val interp_opts : s_opts -> sopt_t list -> (s_opts -> unit Proofview.tactic) (* continuation *) -> unit Proofview.tactic coqhammer-1.3.2-8.20/src/tactics/tactics_main.ml000066400000000000000000000015731471571225200213030ustar00rootroot00000000000000open Ltac_plugin open Proofview.Notations open Hammer_lib open Hammer_errors open Sauto open Tacopts module Utils = Hhutils let try_usolve (opts : s_opts) (lst : sopt_t list) (ret : s_opts -> unit Proofview.tactic) (msg : string) : unit Proofview.tactic = try_tactic begin fun () -> usolve @@ interp_opts opts lst begin fun opts -> Proofview.tclORELSE (ret opts) (fun _ -> Tacticals.tclZEROMSG (Pp.str msg)) end end let with_delayed_uconstr ist c tac = let flags = Pretyping.default_inference_flags false in let c = Tacinterp.type_uconstr ~flags ist c in Tacticals.tclDELAYEDWITHHOLES true c tac let use_lemmas ist lst = let use_tac t = Generalize.generalize [t] <*> Utils.ltac_eval "Tactics.use_tac" [] in List.fold_left (fun tac t -> tac <*> with_delayed_uconstr ist t use_tac) Tacticals.tclIDTAC lst coqhammer-1.3.2-8.20/tests/000077500000000000000000000000001471571225200152265ustar00rootroot00000000000000coqhammer-1.3.2-8.20/tests/plugin/000077500000000000000000000000001471571225200165245ustar00rootroot00000000000000coqhammer-1.3.2-8.20/tests/plugin/Makefile000066400000000000000000000007121471571225200201640ustar00rootroot00000000000000COQC=coqc all: plugin_test.vo basic.vo bugs.vo hashing.vo arith.vo zarith.vo lists.vo misc.vo plugin_test.vo: plugin_test.v $(COQC) plugin_test.v basic.vo: basic.v $(COQC) basic.v bugs.vo: bugs.v $(COQC) bugs.v hashing.vo: hashing.v $(COQC) hashing.v arith.vo: arith.v $(COQC) arith.v zarith.vo: zarith.v $(COQC) zarith.v lists.vo: lists.v $(COQC) lists.v misc.vo: misc.v $(COQC) misc.v clean: -rm -f *.vo *.glob .*.aux .PHONY: all clean coqhammer-1.3.2-8.20/tests/plugin/arith.v000066400000000000000000000017171471571225200200300ustar00rootroot00000000000000From Hammer Require Import Hammer. Require Import Arith. Hammer_version. Hammer_objects. Set Hammer SAutoLimit 0. Lemma lem_1 : le 1 2. hammer. Qed. Lemma lem_2 : forall n : nat, Nat.Odd n \/ Nat.Odd (n + 1). hammer. Qed. Lemma lem_2_1 : forall n : nat, Nat.Even n \/ Nat.Even (n + 1). hammer. Qed. Lemma lem_3 : le 2 3. hammer. Qed. Lemma mult_1 : forall m n k : nat, m * n + k = k + n * m. Proof. hammer. Qed. Lemma lem_rew : forall m n : nat, 1 + n + m + 1 = m + 2 + n. Proof. hammer. Qed. Lemma lem_pow : forall n : nat, 3 * 3 ^ n = 3 ^ (n + 1). Proof. hammer. Qed. Lemma minus_neq_O : forall n i:nat, (i < n) -> (n - i) <> 0. Proof. hammer. Qed. Lemma le_minusni_n : forall n i:nat, i <= n -> n - i <= n. Proof. hammer. Qed. Lemma le_double : forall m n:nat, 2 * m <= 2 * n -> m <= n. Proof. hammer. Qed. Lemma le_plus : forall x, x + x >= x. Proof. hammer. Qed. Lemma le_plus_2 : forall x, x > 0 -> x < x + x. Proof. hammer. Qed. coqhammer-1.3.2-8.20/tests/plugin/basic.v000066400000000000000000000021531471571225200177750ustar00rootroot00000000000000From Hammer Require Import Hammer. Hammer_version. Hammer_objects. Set Hammer SAutoLimit 0. Lemma lem_1 {A : Type} (P : A -> Prop) : forall x, P x -> P x. Proof. hammer. Qed. Lemma lem_2 {A : Type} (P Q : A -> Prop) : forall x, P x \/ Q x -> Q x \/ P x. Proof. hammer. Qed. Lemma lem_3 {A : Type} (P Q : A -> Prop) : forall x, (forall x, P x -> Q x) -> P x -> Q x. Proof. hammer. Qed. Section Sets. Variable U : Type. Variable P : U -> Prop. Variable Q : U -> Prop. Variable R : U -> Prop. Lemma lem_sets_1 : (forall x, P x \/ Q x) /\ (forall x y, x = y /\ P x -> R y) /\ (forall x y, x = y /\ Q x -> R y) -> forall x, R x. Proof. hammer. Qed. Variable Sum : U -> U -> U. Variable Subset : U -> U -> Prop. Variable In : U -> U -> Prop. Variable Seteq : U -> U -> Prop. Lemma lem_sets_2 : (forall A B X, In X (Sum A B) <-> In X A \/ In X B) /\ (forall A B, Seteq A B <-> Subset A B /\ Subset B A) /\ (forall A B, Subset A B <-> forall X, In X A -> In X B) -> (forall A, Seteq (Sum A A) A). Proof. hammer. Qed. End Sets. Lemma lem_inv_1 : forall n, n = 0 \/ exists m, n = S m. Proof. hammer. Qed. coqhammer-1.3.2-8.20/tests/plugin/bugs.v000066400000000000000000000005571471571225200176620ustar00rootroot00000000000000From Hammer Require Import Hammer. Hammer_version. Hammer_objects. Section Bug01. Variable P R : nat -> Prop. Variable Q : nat -> nat -> Prop. Axiom R_implies_P : forall x, R x -> P x. Axiom P_Q_trans : forall x y, P x -> Q x y -> P y. Lemma bug01 : R 0 -> Q 0 1 -> P 1. Proof. intros. eapply P_Q_trans. 2 : apply H0. hammer. Qed. End Bug01. coqhammer-1.3.2-8.20/tests/plugin/dune000066400000000000000000000001251471571225200174000ustar00rootroot00000000000000(rule (alias runtest) (deps (:vfile plugin_test.v)) (action (run coqc %{vfile}))) coqhammer-1.3.2-8.20/tests/plugin/hashing.v000066400000000000000000000033651471571225200203430ustar00rootroot00000000000000From Hammer Require Import Hammer. Require Import List. Hammer_version. Hammer_objects. Set Hammer SAutoLimit 0. Lemma lem_lam_1 {A : Type} (P : (A -> A) -> Prop) : P (fun x => x) -> P (fun x => x). Proof. hammer. Qed. Lemma lem_case_1 (P : nat -> Prop) : forall x, P (match x with 0 => x | S y => y end) -> P (match x with 0 => x | S z => z end). Proof. hammer. Qed. Lemma lem_lam_2 : forall P : (nat -> nat) -> Prop, P (fun x => match x with 0 => 0 | S y => y end) -> P (fun z => match z with 0 => 0 | S u => u end). Proof. hammer. Qed. Lemma lem_lam_3 : forall P : (nat -> nat -> nat) -> Prop, P (fun x y => x + y) -> P (fun a b => a + b). Proof. hammer. Qed. Lemma lem_lam_4 : forall P : (nat -> nat -> nat) -> Prop, P (fun x y => match x with 0 => 0 | S z => z end + y) -> P (fun a b => match a with 0 => 0 | S z => z end + b). Proof. hammer. Qed. Lemma lem_type_1 : forall P : Type -> Prop, P (nat -> nat) -> P (nat -> nat). Proof. hammer. Qed. Lemma lem_type_2 : forall P : (nat -> nat) -> Prop, (forall f, P f) -> forall g, P g. Proof. hammer. Qed. Lemma lem_type_3 : forall P : Type -> Prop, P (nat -> nat -> nat) -> P (nat -> nat -> nat). Proof. hammer. Qed. Lemma lem_forall_conj_trivial {A : Type} (l : list A) (f g : A -> A) (P : A -> Prop) : Forall (fun x => P (f x)) l -> Forall (fun x => P (g x)) l -> Forall (fun x => P (g x)) l /\ Forall (fun x => P (f x)) l. Proof. hammer. Qed. Lemma lem_forall_conj {A : Type} (l : list A) (f g : A -> A) (P : A -> Prop) : Forall (fun x => P (f x)) l -> Forall (fun x => P (g x)) l -> Forall (fun x => P (g x) /\ P (f x)) l. Proof. induction l. strivial. intros H1 H2. inversion_clear H1. inversion_clear H2. apply Forall_cons; hammer. Qed. coqhammer-1.3.2-8.20/tests/plugin/lists.v000066400000000000000000000033101471571225200200460ustar00rootroot00000000000000From Hammer Require Import Hammer. Require Import List. Hammer_version. Hammer_objects. Set Hammer SAutoLimit 0. Lemma lem_lst : forall {A} (x : A) l1 l2 (P : A -> Prop), In x (l1 ++ l2) -> (forall y, In y l1 -> P y) -> (forall y, In y l2 -> P y) -> P x. Proof. hammer. Qed. (* Lemma lem_lst2 : forall {A} (y1 y2 y3 : A) l l' z, In z l \/ In z l' -> In z (y1 :: y2 :: l ++ y3 :: l'). Proof. hammer. Qed. *) Lemma lem_lst3 : forall {A} (l : list A), length (tl l) <= length l. Proof. hammer. Qed. Lemma lem_lst4 : forall {A} (l : list A), l <> nil -> length (tl l) < length l. Proof. hammer. Qed. Lemma incl_app : forall (A : Type) (n l m : list A), List.incl l n /\ List.incl m n -> List.incl (l ++ m) n. Proof. hammer. Qed. Lemma incl_appl : forall (A : Type) (l m n : list A), List.incl l n -> List.incl l (n ++ m) /\ List.incl l (m ++ n) /\ List.incl l (l ++ l). Proof. hammer. Qed. Lemma Forall_1 : forall (A : Type) (P : A -> Prop) (a : A), forall (l l' : list A), List.Forall P l /\ List.Forall P l' /\ P a -> List.Forall P (l ++ a :: l'). Proof. induction l. hammer. hammer. Qed. Lemma Forall_impl : forall (A : Type) (P : A -> Prop), forall l : list A, List.Forall P l -> List.Forall P (l ++ l). Proof. induction l. hammer. hammer. Qed. Lemma lem_lst_1 : forall (A : Type) (l l' : list A), List.NoDup (l ++ l') -> List.NoDup l. Proof. induction l'. hammer. hammer. Qed. Lemma NoDup_remove_1 : forall (A : Type) (a : A) (l' l : list A), List.NoDup (l ++ a :: l') -> ~ List.In a (l ++ l') /\ List.NoDup (l ++ l') /\ List.NoDup l. Proof. hammer. Qed. coqhammer-1.3.2-8.20/tests/plugin/misc.v000066400000000000000000000040251471571225200176470ustar00rootroot00000000000000From Hammer Require Import Hammer. Hammer_version. Hammer_objects. Set Hammer SAutoLimit 0. Require NArith.Ndec. Lemma Nleb_alt : forall b a c : BinNums.N, Ndec.Nleb b c = BinNat.N.leb b c /\ Ndec.Nleb a b = BinNat.N.leb a b. Proof. hammer. Qed. Require NArith.BinNat. Lemma setbit_iff : forall m a n : BinNums.N, n = m \/ true = BinNat.N.testbit a m <-> BinNat.N.testbit (BinNat.N.setbit a n) m = true. Proof. hammer. Qed. Lemma in_int_p_Sq : forall r p q a : nat, a >= 0 -> Between.in_int p (S q) r -> Between.in_int p q r \/ r = q \/ a = 0. Proof. hammer. Qed. Require Reals.Rminmax. Lemma min_spec_1 : forall n m : Rdefinitions.R, (Rdefinitions.Rle m n /\ Rbasic_fun.Rmin m m = m) \/ (Rdefinitions.Rlt n m /\ Rbasic_fun.Rmin m n = n). Proof. hammer. Qed. Lemma min_spec_2 : forall n m : Rdefinitions.R, (Rdefinitions.Rle m n /\ Rbasic_fun.Rmin m n = m) \/ (Rdefinitions.Rlt n m /\ Rbasic_fun.Rmin m n = n). Proof. hammer. Qed. Require Reals.Rpower. Lemma exp_Ropp : forall x y : Rdefinitions.R, Rdefinitions.Rinv (Rtrigo_def.exp x) = Rtrigo_def.exp (Rdefinitions.Ropp x). Proof. hammer. Qed. (* Lemma leb_compare2 : forall m n : nat, PeanoNat.Nat.leb n m = true <-> (PeanoNat.Nat.compare n m = Lt \/ PeanoNat.Nat.compare n m = Eq). Proof. assert (forall c : Datatypes.comparison, c = Eq \/ c = Lt \/ c = Gt) by sauto inverting Datatypes.comparison. (* Reconstr.yelles can do it. Reason: different cost model *) hammer. Qed. *) Lemma leb_1 : forall m n : nat, PeanoNat.Nat.leb m n = true <-> m <= n. Proof. hammer. Qed. Lemma leb_2 : forall m n : nat, PeanoNat.Nat.leb m n = false <-> m > n. Proof. hammer. Qed. Lemma in_int_lt2 : forall p q r : nat, Between.in_int p q r -> q >= p /\ r >= p /\ r <= q. Proof. hammer. Qed. Lemma nat_compare_eq : forall n m : nat, PeanoNat.Nat.compare n m = Eq <-> n = m. Proof. hammer. Qed. coqhammer-1.3.2-8.20/tests/plugin/plugin_test.v000066400000000000000000000007211471571225200212500ustar00rootroot00000000000000From Hammer Require Import Hammer. Hammer_version. Hammer_objects. Lemma lem_1 {A : Type} (P : A -> Prop) : forall x, P x -> P x. Proof. hammer. Qed. Lemma lem_2 {A : Type} (P Q : A -> Prop) : forall x, P x \/ Q x -> Q x \/ P x. Proof. hammer. Qed. Lemma lem_3 {A : Type} (P Q : A -> Prop) : forall x, (forall x, P x -> Q x) -> P x -> Q x. Proof. hammer. Qed. Lemma mult_1 : forall m n k : nat, m * n + k = k + n * m. Proof. predict 16. hammer. Qed. coqhammer-1.3.2-8.20/tests/plugin/zarith.v000066400000000000000000000016171471571225200202210ustar00rootroot00000000000000From Hammer Require Import Hammer. Require Import ZArith. Open Scope Z_scope. Hammer_version. Hammer_objects. Set Hammer SAutoLimit 0. Lemma lem_1 : Z.le 1 2. Proof. hammer. Qed. Lemma lem_2 : forall n : Z, BinInt.Z.Odd n \/ BinInt.Z.Odd (n + 1). Proof. hammer. Qed. Lemma lem_3 : Z.le 2 3. Proof. hammer. Qed. Lemma mult_1 : forall m n k : Z, m * n + k = k + n * m. Proof. hammer. Qed. Lemma lem_rew : forall m n : Z, 1 + n + m + 1 = m + 2 + n. Proof. hammer. Qed. Lemma le_minusni_n : forall n i:Z, i >= 0 -> i <= n -> n - i <= n. Proof. hammer. Qed. Lemma le_double : forall m n:Z, 2 * m <= 2 * n -> m <= n. Proof. hammer. Qed. Lemma le_mul : forall m n k:Z, k > 0 -> k * m <= k * n -> m <= n. Proof. hammer. Qed. Lemma le_plus : forall x:Z, x >= 0 -> x + x >= x. Proof. Unset Hammer CVC4. hammer. Qed. Lemma le_plus_2 : forall x:Z, 0 < x -> x < x + x. Proof. hammer. Qed. coqhammer-1.3.2-8.20/tests/tactics/000077500000000000000000000000001471571225200166605ustar00rootroot00000000000000coqhammer-1.3.2-8.20/tests/tactics/Makefile000066400000000000000000000004171471571225200203220ustar00rootroot00000000000000COQC=coqc all: tactics_test.vo legacy-tests: legacy_tactics_test.v tactics_test.vo: tactics_test.v $(COQC) tactics_test.v legacy_tactics_test.vo: legacy_tactics_test.v $(COQC) legacy_tactics_test.v clean: -rm -f *.vo *.glob .*.aux .PHONY: all clean legacy-tests coqhammer-1.3.2-8.20/tests/tactics/dune000066400000000000000000000001261471571225200175350ustar00rootroot00000000000000(rule (alias runtest) (deps (:vfile tactics_test.v)) (action (run coqc %{vfile}))) coqhammer-1.3.2-8.20/tests/tactics/legacy_tactics_test.v000066400000000000000000000234071471571225200230720ustar00rootroot00000000000000From Hammer Require Import Reconstr. Section Sets. Variable U : Type. Variable P : U -> Prop. Variable Q : U -> Prop. Variable R : U -> Prop. Lemma lem_sets_1 : (forall x, P x \/ Q x) /\ (forall x y, x = y /\ P x -> R y) /\ (forall x y, x = y /\ Q x -> R y) -> forall x, R x. Proof. yelles 2. Qed. Variable Sum : U -> U -> U. Variable Subset : U -> U -> Prop. Variable In : U -> U -> Prop. Variable Seteq : U -> U -> Prop. Lemma lem_sets_2 : (forall A B X, In X (Sum A B) <-> In X A \/ In X B) /\ (forall A B, Seteq A B <-> Subset A B /\ Subset B A) /\ (forall A B, Subset A B <-> forall X, In X A -> In X B) -> (forall A, Seteq (Sum A A) A). Proof. yelles 3. Qed. End Sets. Lemma mult_1 : forall m n k : nat, m * n + k = k + n * m. Proof. reasy (PeanoNat.Nat.mul_comm, PeanoNat.Nat.add_comm) Reconstr.Empty. Qed. Require Import PeanoNat. Require Import Omega. Inductive Term : Set := | LS : Term | LK : Term | LI : Term | LVar : nat -> Term | LApp : Term -> Term -> Term | LLam : nat -> Term -> Term. Fixpoint size (t : Term) : nat := match t with | LS | LK | LVar _ => 1 | LI => 2 | LApp x y => size x + size y + 1 | LLam _ x => size x + 1 end. Fixpoint abstr (v : nat) (t : Term) : Term := match t with | LS | LK | LI => LApp LK t | LVar n => if n =? v then LI else LApp LK t | LApp x y => LApp (LApp LS (abstr v x)) (abstr v y) | LLam _ _ => t end. Fixpoint transl (t : Term) : Term := match t with | LS | LK | LI | LVar _ => t | LApp x y => LApp (transl x) (transl y) | LLam v x => abstr v (transl x) end. (* variable-capturing substitution *) Fixpoint csubst (t : Term) (v : nat) (s : Term) : Term := match t with | LS | LK | LI => t | LVar n => if n =? v then s else t | LApp x y => LApp (csubst x v s) (csubst y v s) | LLam u x => LLam u (csubst x v s) end. Inductive NoLambdas : Term -> Prop := | nl_s : NoLambdas LS | nl_k : NoLambdas LK | nl_i : NoLambdas LI | nl_var : forall n : nat, NoLambdas (LVar n) | nl_app : forall x y : Term, NoLambdas x -> NoLambdas y -> NoLambdas (LApp x y). Lemma no_lams_abstr : forall (v : nat) (t : Term), NoLambdas t -> NoLambdas (abstr v t). Proof. induction t; yelles 3. Qed. Lemma no_lams_transl : forall t : Term, NoLambdas (transl t). Proof. pose proof no_lams_abstr. induction t; yelles 2. Qed. Inductive HasVar : nat -> Term -> Prop := | hs_var : forall n : nat, HasVar n (LVar n) | hs_app : forall (n : nat) (x y : Term), HasVar n x \/ HasVar n y -> HasVar n (LApp x y) | hs_lem : forall (n v : nat) (x : Term), n <> v -> HasVar n x -> HasVar n (LLam v x). Ltac pose_hasvar := generalize hs_var hs_app hs_lem; intros. Lemma vars_abstr : forall (t : Term) (n v : nat), n <> v -> (HasVar n t <-> HasVar n (abstr v t)). Proof. pose_hasvar. induction t; sauto. Reconstr.reasy (@Coq.Arith.EqNat.beq_nat_true) Reconstr.Empty. Qed. Lemma novar_abstr : forall (v : nat) (t : Term), NoLambdas t -> ~(HasVar v (abstr v t)). Proof. pose_hasvar. induction t; sauto. Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.eqb_refl, @Coq.Bool.Bool.not_true_iff_false) Reconstr.Empty. Qed. Lemma vars_transl : forall (t : Term) (n : nat), HasVar n t <-> HasVar n (transl t). Proof. pose_hasvar. induction t; sauto. - Reconstr.reasy (@vars_abstr) Reconstr.Empty. - Reconstr.rsimple (@hs_lem, @vars_abstr, @novar_abstr, @no_lams_transl) Reconstr.Empty. Qed. Notation "X @ Y" := (LApp X Y) (at level 11, left associativity). Inductive WeakEqual : Term -> Term -> Prop := | we_refl : forall (t : Term), WeakEqual t t | we_sym : forall (t u : Term), WeakEqual t u -> WeakEqual u t | we_trans : forall (t u w : Term), WeakEqual t u -> WeakEqual u w -> WeakEqual t w | we_cong : forall (t1 t2 s1 s2 : Term), WeakEqual t1 t2 -> WeakEqual s1 s2 -> WeakEqual (t1 @ s1) (t2 @ s2) | we_s : forall (x y z : Term), WeakEqual (LS @ x @ y @ z) ((x @ z) @ (y @ z)) | we_k : forall (x y : Term), WeakEqual (LK @ x @ y) x | we_i : forall (x y : Term), WeakEqual (LI @ x) x. Ltac pose_we := generalize we_refl we_sym we_trans we_cong we_s we_k we_i; intros. Notation "X =w Y" := (WeakEqual X Y) (at level 80). Lemma abstr_correct : forall (t s : Term) (v : nat), NoLambdas t -> abstr v t @ s =w csubst t v s. Proof. pose_we. induction t; sauto. ycrush. Qed. Lemma abstr_size : forall (t : Term) (v : nat), size (abstr v t) <= 3 * size t. Proof. intros; induction t; sauto; omega. Qed. Lemma lem_pow_3 : (forall x y : nat, 3 ^ x + 3 ^ y + 1 <= 3 ^ (x + y + 1)). Proof. intros. induction x; simpl in *. induction y; simpl in *; omega. omega. Qed. Lemma transl_size : forall (t : Term), size (transl t) <= 3 ^ (size t). Proof. induction t; sauto; try omega. assert (size (transl t1) + size (transl t2) <= 3 ^ size t1 + 3 ^ size t2). Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.add_le_mono) Reconstr.Empty. assert (size (transl t1) + size (transl t2) + 1 <= 3 ^ size t1 + 3 ^ size t2 + 1). auto with zarith. Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.le_lt_trans, @lem_pow_3, @Coq.Arith.PeanoNat.Nat.lt_succ_r) Reconstr.Empty. assert (size (abstr n (transl t)) <= 3 * size (transl t)). pose proof abstr_size; eauto with zarith. assert (size (abstr n (transl t)) <= 3 * 3 ^ size t). pose proof le_trans; eauto with zarith. assert (forall x : nat, 3 * 3 ^ x = 3 ^ (x + 1)). Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.add_0_r, @Coq.Arith.PeanoNat.Nat.pow_succ_r', @Coq.Arith.PeanoNat.Nat.shiftl_1_l, @Coq.Arith.PeanoNat.Nat.pow_1_r, @Coq.Arith.PeanoNat.Nat.pow_0_r, @Coq.Arith.PeanoNat.Nat.add_succ_r) Reconstr.Empty. ycrush. Qed. Lemma abstr_size_lb : forall (t : Term) (v : nat), NoLambdas t -> size (abstr v t) >= 2 * size t. Proof. intros; induction t; sauto; omega. Qed. Fixpoint long_app (n : nat) : Term := match n with | 0 => LVar 0 | S k => LApp (long_app k) (LVar n) end. Fixpoint long_term (n m : nat) : Term := match n with | 0 => LLam m (long_app m) | S k => LLam (m - n) (long_term k m) end. Definition cex_term (n : nat) := long_term n n. Lemma size_nonneg : forall (t : Term), size t > 0. Proof. induction t; simpl; omega. Qed. Lemma transl_size_lb : forall (n : nat), size (transl (cex_term n)) >= 2^n. Proof. assert (forall (n m : nat), size (transl (long_term n m)) >= 2^n). induction n; sauto. Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.nlt_ge, @Coq.Arith.Gt.gt_le_S, @Coq.Arith.Compare_dec.not_ge, @size_nonneg) Reconstr.Empty. assert (size (abstr (m - S n) (transl (long_term n m))) >= 2 * size (transl (long_term n m))). Reconstr.reasy (@abstr_size_lb, @no_lams_transl) Reconstr.Empty. assert (size (abstr (m - S n) (transl (long_term n m))) >= 2 * 2 ^ n). pose proof (IHn m); eauto with zarith. scrush. now unfold cex_term. Qed. Fixpoint occurs (v : nat) (t : Term) : bool := match t with | LS | LK | LI => false | LVar n => if n =? v then true else false | LApp x y => orb (occurs v x) (occurs v y) | LLam n b => if n =? v then false else occurs v b end. Lemma occurs_spec : forall (v : nat) (t : Term), occurs v t = true <-> HasVar v t. Proof. pose_hasvar. pose proof Coq.Arith.EqNat.beq_nat_true. pose proof Coq.Arith.EqNat.beq_nat_false. induction t; sauto; unfold orb; try yelles 2. assert (occurs v t1 = true \/ occurs v t2 = true). Reconstr.reasy (@Coq.Bool.Bool.orb_prop) Reconstr.Empty. yelles 1. Qed. Fixpoint abstr2 (v : nat) (t : Term) : Term := if occurs v t then match t with | LS | LK | LI => LApp LK t | LVar n => if n =? v then LI else LApp LK t | LApp x y => LApp (LApp LS (abstr2 v x)) (abstr2 v y) | LLam _ _ => t end else LApp LK t. Fixpoint transl2 (t : Term) : Term := match t with | LS | LK | LI | LVar _ => t | LApp x y => LApp (transl2 x) (transl2 y) | LLam v x => abstr2 v (transl2 x) end. Lemma no_lams_abstr2 : forall (v : nat) (t : Term), NoLambdas t -> NoLambdas (abstr2 v t). Proof. induction t; yelles 3. Qed. Lemma no_lams_transl2 : forall t : Term, NoLambdas (transl2 t). Proof. pose proof no_lams_abstr2. induction t; yelles 2. Qed. Lemma vars_abstr2 : forall (t : Term) (n v : nat), n <> v -> (HasVar n t <-> HasVar n (abstr2 v t)). Proof. pose_hasvar. induction t; sauto. Reconstr.reasy (@Coq.Arith.EqNat.beq_nat_true) Reconstr.Empty. Qed. Lemma novar_abstr2 : forall (v : nat) (t : Term), NoLambdas t -> ~(HasVar v (abstr2 v t)). Proof. pose_hasvar. pose (u := t). induction t; destruct (occurs v u) eqn:?; sauto. - Reconstr.reasy (@Coq.Arith.PeanoNat.Nat.eqb_refl, @Coq.Bool.Bool.not_true_iff_false) Reconstr.Empty. - Reconstr.rsimple (@occurs_spec, @Coq.Bool.Bool.not_true_iff_false) (@Coq.Init.Datatypes.orb). - Reconstr.rscrush (@occurs_spec, @Coq.Bool.Bool.not_true_iff_false) (@Coq.Init.Datatypes.orb). Qed. Lemma vars_transl2 : forall (t : Term) (n : nat), HasVar n t <-> HasVar n (transl2 t). Proof. pose_hasvar. induction t; sauto. - Reconstr.reasy (@vars_abstr2) Reconstr.Empty. - Reconstr.rsimple (@no_lams_transl2, @vars_abstr2, @novar_abstr2, @hs_lem) Reconstr.Empty. Qed. Lemma hasvar_inv : forall (t1 t2 : Term) (v : nat), ~(HasVar v (t1 @ t2)) -> ~(HasVar v t1) /\ ~(HasVar v t2). Proof. scrush. Qed. Lemma csubst_novar : forall (t s : Term) (v : nat), NoLambdas t -> ~(HasVar v t) -> csubst t v s = t. Proof. pose_hasvar. induction t; sauto. Reconstr.rsimple (@Coq.Arith.EqNat.beq_nat_true) Reconstr.Empty. Qed. Lemma abstr2_correct : forall (t s : Term) (v : nat), NoLambdas t -> abstr2 v t @ s =w csubst t v s. Proof. pose_we. induction t; sauto. ycrush. assert (HH: forall b1 b2, (b1 || b2)%bool = false -> b1 = false /\ b2 = false). unfold orb; ycrush. pose proof occurs_spec. rewrite csubst_novar by ycrush. rewrite csubst_novar by ycrush. ycrush. Qed. Lemma abstr2_size_ub : forall (t : Term) (v : nat), size (abstr2 v t) <= 3 * size t. Proof. intros; induction t; sauto; omega. Qed. coqhammer-1.3.2-8.20/tests/tactics/tactics_test.v000066400000000000000000001203531471571225200215440ustar00rootroot00000000000000From Hammer Require Import Tactics. (* Basic tests *) Lemma lem_test_1 : (forall x y, x + y = y + x -> False) -> forall x, x > x. ssimpl. Qed. Lemma lem_test_1_1 : (forall x, x >= x /\ x < x + x) -> forall x, x >= x /\ x < x + x. strivial. Qed. Lemma lem_test_2 : (forall x, x > x) -> (forall x, x + x > x) -> exists x, x > x \/ x + x > x. strivial. Qed. Lemma lem_test_3 : (forall x, x > x) -> (forall x, x + x > x) -> { x & { x > x } + { x + x > x } }. strivial. Qed. Lemma lem_test_4 : (forall x, x + x > x) -> { x & { x > x } + { x + x > x } }. hauto. Qed. Lemma lem_test_5 : (forall P : nat -> Prop, P 0 -> (forall x, P x -> P (S x)) -> P 60). hauto. Qed. Lemma lem_test_6 : (forall P : nat -> Prop, P 0 -> P (S 0) -> (forall x, P x -> P (S x) -> P (S (S x))) -> P 20). sblast. Qed. Definition ff := False. Lemma lem_test_def : (forall P : Prop, P \/ (P -> ff) -> ((P -> ff) -> False) -> P). Proof. hauto. Qed. Definition feq (x y z : nat) : Prop := x + y + z = x * y + z. Lemma lem_sym_feq : (forall x y z, feq x y z) -> forall x y z, x * y + z = x + y + z. Proof. sauto. Qed. Lemma lem_implicit_arg {A} : forall l : list A, List.map id l = l. Proof. sauto use: List.map_id. Qed. Lemma test_implicit_arg1 {A} : forall l : list A, List.map id l = l. Proof. sauto use: lem_implicit_arg. Qed. Class Mere A := { mere : forall x y : A, x = y }. Lemma lem_implicit_arg2 {A} `{Mere A} {B} (f g : B -> A) : forall l : list B, List.map f l = List.map g l. Proof. induction l; sauto. Qed. Global Instance mere_unit : Mere unit. Proof. sauto. Qed. Lemma test_implicit_arg2 {B} : forall (l: list B) (f g : B -> unit), List.map f l = List.map g l. Proof. sauto use: lem_implicit_arg2. Qed. (* Argument parsing test *) Lemma lem_q (q: nat): q = q. Proof. sauto q: on. Qed. Lemma lem_l (l: nat): l = l. Proof. sauto l: on. Qed. Lemma lem_lq (lq: nat): lq = lq. Proof. sauto lq: on. Qed. Lemma lem_depth (depth: nat): depth = depth. Proof. sauto depth: 1. Qed. (* More tests *) Require Import Arith. Lemma lem_test_csplit : forall n, if n =? n then True else False. Proof. sauto cases: bool. Qed. Lemma lem_odd : forall n : nat, Nat.Odd n \/ Nat.Odd (n + 1). hauto use: @Coq.Arith.PeanoNat.Nat.Odd_succ, @Coq.Arith.PeanoNat.Nat.Even_or_Odd, @Coq.Arith.PeanoNat.Nat.add_1_r. Qed. Lemma lem_2_1 : forall n : nat, Nat.Even n \/ Nat.Even (n + 1). hauto using (@Coq.Arith.PeanoNat.Nat.Even_succ, @Coq.Arith.PeanoNat.Nat.add_1_r, @Coq.Arith.PeanoNat.Nat.Even_or_Odd). Qed. Lemma lem_mult_1 : forall m n k : nat, m * n + k = k + n * m. Proof. hauto using (PeanoNat.Nat.mul_comm, PeanoNat.Nat.add_comm). Qed. Lemma lem_pow : forall n : nat, 3 * 3 ^ n = 3 ^ (n + 1). hauto using (Coq.Arith.PeanoNat.Nat.pow_succ_r, Coq.Arith.PeanoNat.Nat.add_1_r, Coq.Arith.PeanoNat.Nat.le_0_l). Qed. Lemma lem_even_or_odd : forall n:nat, exists p : nat, n = (2 * p) \/ n = S (2 * p). Proof. induction n; sintuition ered: off. exists (S p); strivial. Qed. Require Import ZArith. Lemma le_mul : forall m n k : Z, (k > 0 -> k * m <= k * n -> m <= n)%Z. Proof. hauto use: Coq.ZArith.BinInt.Z.mul_comm, Coq.ZArith.BinInt.Z.mul_le_mono_pos_r, Coq.ZArith.BinInt.Z.gt_lt_iff. Qed. Lemma lem_bnat_test_1 : forall x y, Nat.eqb x y = true -> y = x. Proof. intros. bnat_reflect. assumption. Qed. Lemma lem_bnat_test_2 : forall x y, Nat.eqb x y = false -> x = y -> False. Proof. intros x y H. bnat_reflect. assumption. Qed. Lemma lem_bnat_test_3 : forall x y, Nat.leb x y = true -> x <= y. Proof. intros x y H. bnat_reflect. assumption. Qed. Lemma lem_bnat_test_4 : forall x y, Nat.leb x y = false -> y < x. Proof. intros x y H. bnat_reflect. assumption. Qed. Lemma lem_bnat_test_5 : forall x y, Nat.ltb x y = true -> x < y. Proof. intros x y H. bnat_reflect. assumption. Qed. Lemma lem_bnat_test_6 : forall x y, Nat.ltb x y = false -> y <= x. Proof. intros x y H. bnat_reflect. assumption. Qed. Require NArith.BinNat. Lemma lem_nbnat_test_1 : forall x y, BinNat.N.eqb x y = true -> x = y. Proof. intros. bnat_reflect. assumption. Qed. Lemma lem_nbnat_test_2 : forall x y, BinNat.N.eqb x y = false -> x = y -> False. Proof. intros x y H. bnat_reflect. assumption. Qed. Lemma setbit_iff : forall m a n : BinNums.N, n = m \/ true = BinNat.N.testbit a m <-> BinNat.N.testbit (BinNat.N.setbit a n) m = true. Proof. scrush using (@NArith.BinNat.N.setbit_iff). Qed. Section Sets. Variable U : Type. Variable P : U -> Prop. Variable Q : U -> Prop. Variable R : U -> Prop. Lemma lem_sets_1 : (forall x, P x \/ Q x) /\ (forall x y, x = y /\ P x -> R y) /\ (forall x y, x = y /\ Q x -> R y) -> forall x, R x. Proof. hauto. Qed. Lemma lem_sets_1_1 : (forall x, P x \/ Q x) /\ (forall x y, x = y /\ P x -> R y) /\ (forall x y, x = y /\ Q x -> R y) -> forall x, R x. Proof. sauto inv: list. Qed. Variable Sum : U -> U -> U. Variable Subset : U -> U -> Prop. Variable In : U -> U -> Prop. Variable Seteq : U -> U -> Prop. Lemma lem_sets_2 : (forall A B X, In X (Sum A B) <-> In X A \/ In X B) /\ (forall A B, Seteq A B <-> Subset A B /\ Subset B A) /\ (forall A B, Subset A B <-> forall X, In X A -> In X B) -> (forall A, Seteq (Sum A A) A). Proof. hauto. Qed. End Sets. Section FOFProblem1. Variable Universe : Set. Variable r : Universe -> Prop. Variable q : Universe -> Universe -> Prop. Variable p : Universe -> Prop. Variable axiom1_1 : (forall X : Universe, (p X -> (r X \/ (exists Y : Universe, q X Y)))). Variable axiom2_2 : (forall X : Universe, (r X -> ~((exists X : Universe, p X)))). Variable axiom3_3 : (exists X : Universe, p X). Theorem con_4 : (exists X : Universe, (exists Y : Universe, q X Y)). Proof. hauto. Qed. End FOFProblem1. Section FOFProblem2. Variable Universe : Set. Variable UniverseElement : Universe. Variable a_ : Universe -> Universe -> Prop. Theorem prove_this_1 : (forall X : Universe, (exists Y : Universe, (a_ X Y /\ a_ Y Y))) -> (exists Z : Universe, a_ Z Z). Proof. sauto. Qed. End FOFProblem2. Inductive R_add : nat -> nat -> nat -> Prop := | R_add_0 : forall m, R_add 0 m m | R_add_S : forall p m k, R_add p m k -> R_add (S p) m (S k). Global Hint Constructors R_add : R_add_db. Lemma lem_minus : exists x, R_add x 2 20. Proof. hauto db: R_add_db. Qed. Require Import List. Require Import Lia. From Hammer Require Import Hints. Section Lists. Lemma lem_lst : forall {A} (x : A) l1 l2 (P : A -> Prop), In x (l1 ++ l2) -> (forall y, In y l1 -> P y) -> (forall y, In y l2 -> P y) -> P x. Proof. sauto db: slist. Qed. Lemma lem_lst2 : forall {A} (y1 y2 y3 : A) l l' z, In z l \/ In z l' -> In z (y1 :: y2 :: l ++ y3 :: l'). Proof. sauto db: slist. Qed. Lemma lem_lst3 : forall {A} (l : list A), length (tl l) <= length l. Proof. hauto inv: list. Qed. Lemma lem_lst4 : forall {A} (l : list A), l <> nil -> length (tl l) < length l. Proof. hauto inv: list. Qed. Lemma lem_lst5 : forall (A : Type) (l l' : list A), List.NoDup (l ++ l') -> List.NoDup l. Proof. induction l'. - hauto using (@Lists.List.app_nil_r). - hauto using (@Lists.List.NoDup_remove_1). Qed. End Lists. Require Import Reals. Require Import Lra. Section Real. Local Open Scope R_scope. Lemma lem_real_1 : forall x y, x + y = y + x. Proof. sauto solve: lra. Qed. Lemma lem_real_2 P : (forall a b, P a -> a = b -> P b) -> forall x y, P (x + y) -> P (y + x). Proof. qauto solve: lra. Qed. End Real. From Hammer Require Import Reflect. Lemma lem_breflect_test_1 : forall b1 b2 b3, b1 && b2 || b3 -> b3 || b2 || b1. Proof. intros. breflect in *. tauto. Qed. Lemma lem_breflect_test_2 : forall b1 b2 b3, implb (b1 && b2 || b3) (b3 || b2 || b1). Proof. intros. breflect. tauto. Qed. Lemma lem_breflect_test_3 : forall b1 b2 b3, eqb (b1 && b2 || b3) (b3 || b2 && b1). Proof. intros. breflect. tauto. Qed. Lemma lem_breflect_test_1' : forall b1 b2 b3, b1 && b2 || b3 -> b3 || b2 || b1. Proof. breflect. tauto. Qed. Lemma lem_breflect_test_2' : forall b1 b2 b3, implb (b1 && b2 || b3) (b3 || b2 || b1). Proof. breflect. tauto. Qed. Lemma lem_breflect_test_3' : forall b1 b2 b3, eqb (b1 && b2 || b3) (b3 || b2 && b1). Proof. breflect. tauto. Qed. Lemma lem_breflect_test_4 : forall b1 b2 b3, (forall n, Nat.eqb n n) -> (implb (b1 || b2) (Nat.eqb 0 0 && (b2 || b1 || b3))). Proof. breflect. tauto. Qed. Lemma lem_bauto_test_1 : forall b1 b2 b3, b1 && b2 || b3 -> b3 || b2 || b1. Proof. sauto. Qed. Lemma lem_bauto_test_2 : forall b1 b2 b3, implb (b1 && b2 || b3) (b3 || b2 || b1). Proof. sauto. Qed. Lemma lem_bauto_test_3 : forall b1 b2 b3, eqb (b1 && b2 || b3) (b3 || b2 && b1). Proof. sauto. Qed. Require Import Nat. Require Import Psatz. Inductive Term : Set := | LS : Term | LK : Term | LI : Term | LVar : nat -> Term | LApp : Term -> Term -> Term | LLam : nat -> Term -> Term. Fixpoint size (t : Term) : nat := match t with | LS | LK | LVar _ => 1 | LI => 2 | LApp x y => size x + size y + 1 | LLam _ x => size x + 1 end. Fixpoint abstr (v : nat) (t : Term) : Term := match t with | LS | LK | LI => LApp LK t | LVar n => if n =? v then LI else LApp LK t | LApp x y => LApp (LApp LS (abstr v x)) (abstr v y) | LLam _ _ => t end. Fixpoint transl (t : Term) : Term := match t with | LS | LK | LI | LVar _ => t | LApp x y => LApp (transl x) (transl y) | LLam v x => abstr v (transl x) end. (* variable-capturing substitution *) Fixpoint csubst (t : Term) (v : nat) (s : Term) : Term := match t with | LS | LK | LI => t | LVar n => if n =? v then s else t | LApp x y => LApp (csubst x v s) (csubst y v s) | LLam u x => LLam u (csubst x v s) end. Inductive NoLambdas : Term -> Prop := | nl_s : NoLambdas LS | nl_k : NoLambdas LK | nl_i : NoLambdas LI | nl_var : forall n : nat, NoLambdas (LVar n) | nl_app : forall x y : Term, NoLambdas x -> NoLambdas y -> NoLambdas (LApp x y). Lemma no_lams_abstr : forall (v : nat) (t : Term), NoLambdas t -> NoLambdas (abstr v t). Proof. induction t; sauto. Qed. Lemma no_lams_transl : forall t : Term, NoLambdas (transl t). Proof. induction t; sauto using no_lams_abstr. Qed. Inductive HasVar : nat -> Term -> Prop := | hs_var : forall n : nat, HasVar n (LVar n) | hs_app : forall (n : nat) (x y : Term), HasVar n x \/ HasVar n y -> HasVar n (LApp x y) | hs_lem : forall (n v : nat) (x : Term), n <> v -> HasVar n x -> HasVar n (LLam v x). Lemma vars_abstr : forall (t : Term) (n v : nat), n <> v -> (HasVar n t <-> HasVar n (abstr v t)). Proof. induction t; scrush. Qed. Lemma novar_abstr : forall (v : nat) (t : Term), NoLambdas t -> ~(HasVar v (abstr v t)). Proof. induction t; qsimpl. Qed. Lemma vars_transl : forall (t : Term) (n : nat), HasVar n t <-> HasVar n (transl t). Proof. induction t; qsimpl. - hauto using vars_abstr. - hauto use: @no_lams_transl, @vars_abstr, @novar_abstr, @hs_lem. Qed. Notation "X @ Y" := (LApp X Y) (at level 11, left associativity). Inductive WeakEqual : Term -> Term -> Prop := | we_refl : forall (t : Term), WeakEqual t t | we_sym : forall (t u : Term), WeakEqual t u -> WeakEqual u t | we_trans : forall (t u w : Term), WeakEqual t u -> WeakEqual u w -> WeakEqual t w | we_cong : forall (t1 t2 s1 s2 : Term), WeakEqual t1 t2 -> WeakEqual s1 s2 -> WeakEqual (t1 @ s1) (t2 @ s2) | we_s : forall (x y z : Term), WeakEqual (LS @ x @ y @ z) ((x @ z) @ (y @ z)) | we_k : forall (x y : Term), WeakEqual (LK @ x @ y) x | we_i : forall (x y : Term), WeakEqual (LI @ x) x. Notation "X =w Y" := (WeakEqual X Y) (at level 80). Lemma abstr_correct : forall (t s : Term) (v : nat), NoLambdas t -> abstr v t @ s =w csubst t v s. Proof. induction t; scrush. Qed. Lemma abstr_size : forall (t : Term) (v : nat), size (abstr v t) <= 3 * size t. Proof. intros; induction t; qsimpl. Qed. Lemma lem_pow_3 : (forall x y : nat, 3 ^ x + 3 ^ y + 1 <= 3 ^ (x + y + 1)). Proof. intros. induction x; simpl in *. induction y; simpl in *; lia. lia. Qed. Lemma transl_size : forall (t : Term), size (transl t) <= 3 ^ (size t). Proof. induction t; sintuition. - assert (size (transl t1) + size (transl t2) <= 3 ^ size t1 + 3 ^ size t2). { eauto using PeanoNat.Nat.add_le_mono. } assert (size (transl t1) + size (transl t2) + 1 <= 3 ^ size t1 + 3 ^ size t2 + 1). { auto with zarith. } hauto use: Nat.le_trans, lem_pow_3. - assert (size (abstr n (transl t)) <= 3 * size (transl t)). { eauto using abstr_size with zarith. } assert (size (abstr n (transl t)) <= 3 * 3 ^ size t). { eauto using Nat.le_trans with zarith. } assert (forall x : nat, 3 * 3 ^ x = 3 ^ (x + 1)) by hauto using Nat.add_1_r. congruence. Qed. Lemma abstr_size_lb : forall (t : Term) (v : nat), NoLambdas t -> size (abstr v t) >= 2 * size t. Proof. intros; induction t; qsimpl. Qed. Fixpoint long_app (n : nat) : Term := match n with | 0 => LVar 0 | S k => LApp (long_app k) (LVar n) end. Fixpoint long_term (n m : nat) : Term := match n with | 0 => LLam m (long_app m) | S k => LLam (m - n) (long_term k m) end. Definition cex_term (n : nat) := long_term n n. Lemma size_nonneg : forall (t : Term), size t > 0. Proof. induction t; simpl; lia. Qed. Lemma transl_size_lb : forall (n : nat), size (transl (cex_term n)) >= 2^n. Proof. assert (forall (n m : nat), size (transl (long_term n m)) >= 2^n). induction n; ssimpl. - sauto. - assert (size (abstr (m - S n) (transl (long_term n m))) >= 2 * size (transl (long_term n m))). { hauto using (@abstr_size_lb, @no_lams_transl). } assert (size (abstr (m - S n) (transl (long_term n m))) >= 2 * 2 ^ n). { pose proof (IHn m); eauto with zarith. } scrush. - now unfold cex_term. Qed. Fixpoint occurs (v : nat) (t : Term) : bool := match t with | LS | LK | LI => false | LVar n => n =? v | LApp x y => occurs v x || occurs v y | LLam n b => negb (n =? v) && occurs v b end. Lemma occurs_spec : forall (v : nat) (t : Term), occurs v t <-> HasVar v t. Proof. induction t; sauto b: on. Qed. Fixpoint abstr2 (v : nat) (t : Term) : Term := if occurs v t then match t with | LS | LK | LI => LApp LK t | LVar n => if n =? v then LI else LApp LK t | LApp x y => LApp (LApp LS (abstr2 v x)) (abstr2 v y) | LLam _ _ => t end else LApp LK t. Fixpoint transl2 (t : Term) : Term := match t with | LS | LK | LI | LVar _ => t | LApp x y => LApp (transl2 x) (transl2 y) | LLam v x => abstr2 v (transl2 x) end. Lemma no_lams_abstr2 : forall (v : nat) (t : Term), NoLambdas t -> NoLambdas (abstr2 v t). Proof. induction t; scrush. Qed. Lemma no_lams_transl2 : forall t : Term, NoLambdas (transl2 t). Proof. induction t; sauto using no_lams_abstr2. Qed. Lemma vars_abstr2 : forall (t : Term) (n v : nat), n <> v -> (HasVar n t <-> HasVar n (abstr2 v t)). Proof. induction t; scrush. Qed. Lemma novar_abstr2 : forall (v : nat) (t : Term), NoLambdas t -> ~(HasVar v (abstr2 v t)). Proof. intros. pose (u := t). induction t; bdestruct (occurs v u); scrush using occurs_spec. Qed. Lemma vars_transl2 : forall (t : Term) (n : nat), HasVar n t <-> HasVar n (transl2 t). Proof. induction t; qsimpl. - hauto using (@vars_abstr2). - hauto using (@no_lams_transl2, @vars_abstr2, @novar_abstr2, @hs_lem). Qed. Lemma hasvar_inv : forall (t1 t2 : Term) (v : nat), ~(HasVar v (t1 @ t2)) -> ~(HasVar v t1) /\ ~(HasVar v t2). Proof. sauto. Qed. Lemma csubst_novar : forall (t s : Term) (v : nat), NoLambdas t -> ~(HasVar v t) -> csubst t v s = t. Proof. intros; induction t; sauto. Qed. Lemma abstr2_correct : forall (t s : Term) (v : nat), NoLambdas t -> abstr2 v t @ s =w csubst t v s. Proof. induction t; qsimpl. - sauto. - sauto. - use occurs_spec. rewrite csubst_novar by ssimpl. rewrite csubst_novar by ssimpl. strivial. Qed. Lemma abstr2_size_ub : forall (t : Term) (v : nat), size (abstr2 v t) <= 3 * size t. Proof. intros; induction t; qsimpl. Qed. Require Import String. Inductive aexpr := | Nval : nat -> aexpr | Vval : string -> aexpr | Aplus : aexpr -> aexpr -> aexpr. Definition state := string -> nat. Fixpoint aval (s : state) (e : aexpr) := match e with | Nval n => n | Vval x => s x | Aplus x y => aval s x + aval s y end. Definition plus (e1 e2 : aexpr) := match e1, e2 with | Nval n1, Nval n2 => Nval (n1 + n2) | Nval 0, _ => e2 | _, Nval 0 => e1 | _, _ => Aplus e1 e2 end. Lemma lem_aval_plus : forall s e1 e2, aval s (plus e1 e2) = aval s e1 + aval s e2. Proof. induction e1; sauto. Qed. Fixpoint asimp (e : aexpr) := match e with | Aplus x y => plus (asimp x) (asimp y) | _ => e end. Lemma lem_aval_asimp : forall s e, aval s (asimp e) = aval s e. Proof. induction e; sauto use: lem_aval_plus. Qed. Inductive bexpr := | Bval : bool -> bexpr | Bnot : bexpr -> bexpr | Band : bexpr -> bexpr -> bexpr | Bless : aexpr -> aexpr -> bexpr. Fixpoint bval (s : state) (e : bexpr) := match e with | Bval b => b | Bnot e1 => negb (bval s e1) | Band e1 e2 => bval s e1 && bval s e2 | Bless a1 a2 => aval s a1 Bval false | Bval false => Bval true | _ => Bnot e end. Definition and (e1 e2 : bexpr) := match e1, e2 with | Bval true, _ => e2 | _, Bval true => e1 | Bval false, _ => Bval false | _, Bval false => Bval false | _, _ => Band e1 e2 end. Definition less (a1 a2 : aexpr) := match a1, a2 with | Nval n1, Nval n2 => Bval (n1 Bless a1 a2 end. Fixpoint bsimp (e : bexpr) := match e with | Bnot e1 => not (bsimp e1) | Band e1 e2 => and (bsimp e1) (bsimp e2) | Bless a1 a2 => less a1 a2 | _ => e end. Lemma lem_bval_not : forall s e, bval s (not e) = negb (bval s e). Proof. induction e; sauto. Qed. Lemma lem_bval_and : forall s e1 e2, bval s (and e1 e2) = bval s e1 && bval s e2. Proof. induction e1; sauto db: sbool. Qed. Lemma lem_bval_less : forall s a1 a2, bval s (less a1 a2) = (aval s a1 aexpr -> cmd | Seq : cmd -> cmd -> cmd | If : bexpr -> cmd -> cmd -> cmd | While : bexpr -> cmd -> cmd. Notation "A <- B" := (Assign A B) (at level 60). Notation "A ;; B" := (Seq A B) (at level 70). Notation "'If' A 'Then' B 'Else' C" := (If A B C) (at level 65). Notation "'While' A 'Do' B" := (While A B) (at level 65). Definition update (s : state) x v y := if string_dec x y then v else s y. Definition state_subst (s : state) (x : string) (a : aexpr) : state := (update s x (aval s a)). Notation "s [[ x := a ]]" := (state_subst s x a) (at level 5). (* Big-step operational semantics *) Inductive BigStep : cmd -> state -> state -> Prop := | NopSem : forall s, BigStep Nop s s | AssignSem : forall s x a, BigStep (x <- a) s s[[x := a]] | SeqSem : forall c1 c2 s1 s2 s3, BigStep c1 s1 s2 -> BigStep c2 s2 s3 -> BigStep (c1 ;; c2) s1 s3 | IfTrue : forall b c1 c2 s s', bval s b -> BigStep c1 s s' -> BigStep (If b Then c1 Else c2) s s' | IfFalse : forall b c1 c2 s s', negb (bval s b) -> BigStep c2 s s' -> BigStep (If b Then c1 Else c2) s s' | WhileFalse : forall b c s, negb (bval s b) -> BigStep (While b Do c) s s | WhileTrue : forall b c s1 s2 s3, bval s1 b -> BigStep c s1 s2 -> BigStep (While b Do c) s2 s3 -> BigStep (While b Do c) s1 s3. Notation "A >> B ==> C" := (BigStep A B C) (at level 80, no associativity). Lemma lem_big_step_deterministic : forall c s s1, c >> s ==> s1 -> forall s2, c >> s ==> s2 -> s1 = s2. Proof. induction 1; sauto brefl: on. Qed. (* Program equivalence *) Definition equiv_cmd (c1 c2 : cmd) := forall s s', c1 >> s ==> s' <-> c2 >> s ==> s'. Notation "A ~~ B" := (equiv_cmd A B) (at level 75, no associativity). Lemma lem_sim_refl : forall c, c ~~ c. Proof. sauto. Qed. Lemma lem_sim_sym : forall c c', c ~~ c' -> c' ~~ c. Proof. sauto unfold: equiv_cmd. Qed. Lemma lem_sim_trans : forall c1 c2 c3, c1 ~~ c2 -> c2 ~~ c3 -> c1 ~~ c3. Proof. sauto unfold: equiv_cmd. Qed. Lemma lem_seq_assoc : forall c1 c2 c3, c1;; (c2;; c3) ~~ (c1;; c2);; c3. Proof. sauto lazy: on unfold: equiv_cmd. Qed. Lemma lem_triv_if : forall b c, If b Then c Else c ~~ c. Proof. unfold equiv_cmd. intros b c s s'. destruct (bval s b) eqn:?; sauto. Qed. Lemma lem_commute_if : forall b1 b2 c1 c2 c3, If b1 Then (If b2 Then c1 Else c2) Else c3 ~~ If b2 Then (If b1 Then c1 Else c3) Else (If b1 Then c2 Else c3). Proof. unfold equiv_cmd. intros *. destruct (bval s b1) eqn:?; destruct (bval s b2) eqn:?; sauto lq: on inv: BigStep ctrs: BigStep. Qed. Lemma lem_unfold_while : forall b c, While b Do c ~~ If b Then c;; While b Do c Else Nop. Proof. sauto l: on unfold: equiv_cmd. Qed. Lemma lem_while_cong_aux : forall b c c' s s', While b Do c >> s ==> s' -> c ~~ c' -> While b Do c' >> s ==> s'. Proof. intros *. remember (While b Do c). induction 1; sauto lq: on unfold: equiv_cmd. Qed. Lemma lem_while_cong : forall b c c', c ~~ c' -> While b Do c ~~ While b Do c'. Proof. hauto use: lem_while_cong_aux unfold: equiv_cmd. Qed. (* Small-step operational semantics *) Inductive SmallStep : cmd * state -> cmd * state -> Prop := | AssignSemS : forall x a s, SmallStep (x <- a, s) (Nop, s[[x := a]]) | SeqSemS1 : forall c s, SmallStep (Nop ;; c, s) (c, s) | SeqSemS2 : forall c1 c2 s c1' s', SmallStep (c1, s) (c1', s') -> SmallStep (c1 ;; c2, s) (c1';; c2, s') | IfTrueS : forall b c1 c2 s, bval s b -> SmallStep (If b Then c1 Else c2, s) (c1, s) | IfFalseS : forall b c1 c2 s, negb (bval s b) -> SmallStep (If b Then c1 Else c2, s) (c2, s) | WhileS : forall b c s, SmallStep (While b Do c, s) (If b Then c;; While b Do c Else Nop, s). Notation "A --> B" := (SmallStep A B) (at level 80, no associativity). Require Import Relations. Definition SmallStepStar := clos_refl_trans (cmd * state) SmallStep. Notation "A -->* B" := (SmallStepStar A B) (at level 80, no associativity). Lemma lem_small_step_deterministic : forall p p1, p --> p1 -> forall p2, p --> p2 -> p1 = p2. Proof. induction 1; sauto lq: on brefl: on. Qed. (* Equivalence between big-step and small-step operational semantics *) Lemma lem_star_seq2 : forall c1 c2 s c1' s', (c1, s) -->* (c1', s') -> (c1;; c2, s) -->* (c1';; c2, s'). Proof. enough (forall p1 p2, p1 -->* p2 -> forall c1 c2 s c1' s', p1 = (c1, s) -> p2 = (c1', s') -> (c1;; c2, s) -->* (c1';; c2, s')). { eauto. } induction 1; sauto lq: on. Qed. Lemma lem_seq_comp : forall c1 c2 s1 s2 s3, (c1, s1) -->* (Nop, s2) -> (c2, s2) -->* (Nop, s3) -> (c1;; c2, s1) -->* (Nop, s3). Proof. intros c1 c2 s1 s2 s3 H1 H2. assert ((c1;; c2, s1) -->* (Nop;; c2, s2)) by sauto use: lem_star_seq2. sauto. Qed. Lemma lem_big_to_small : forall c s s', c >> s ==> s' -> (c, s) -->* (Nop, s'). Proof. intros c s s' H. induction H as [ | | | | | | b c s1 s2 ]. - sauto. - sauto. - sauto use: lem_seq_comp. - sauto. - sauto. - sauto. - assert ((While b Do c, s1) -->* (c;; While b Do c, s1)) by sauto. assert ((c;; While b Do c, s1) -->* (Nop;; While b Do c, s2)) by sauto use: lem_star_seq2. sauto. Qed. Lemma lem_small_to_big_aux : forall p p', p --> p' -> forall c1 s1 c2 s2 s, p = (c1, s1) -> p' = (c2, s2) -> c2 >> s2 ==> s -> c1 >> s1 ==> s. Proof. induction 1; sauto lq: on. Qed. Lemma lem_small_to_big_aux_2 : forall p p', p -->* p' -> forall c1 s1 c2 s2 s, p = (c1, s1) -> p' = (c2, s2) -> c2 >> s2 ==> s -> c1 >> s1 ==> s. Proof. induction 1; sauto use: lem_small_to_big_aux. Qed. Lemma lem_small_to_big : forall c s s', (c, s) -->* (Nop, s') -> c >> s ==> s'. Proof. enough (forall p p', p -->* p' -> forall c s s', p = (c, s) -> p' = (Nop, s') -> c >> s ==> s') by eauto. induction 1; sauto l: on use: lem_small_to_big_aux_2. Qed. Corollary cor_big_iff_small : forall c s s', c >> s ==> s' <-> (c, s) -->* (Nop, s'). Proof. sauto use: lem_small_to_big, lem_big_to_small. Qed. (* Hoare triples *) Definition assn := state -> Prop. Definition HoareValid (P : assn) (c : cmd) (Q : assn): Prop := forall s s', c >> s ==> s' -> P s -> Q s'. Notation "|= {{ P }} c {{ Q }}" := (HoareValid P c Q). (* Hoare logic *) Definition entails (P Q : assn) : Prop := forall s, P s -> Q s. Inductive Hoare : assn -> cmd -> assn -> Prop := | Hoare_Nop : forall P, Hoare P Nop P | Hoare_Assign : forall P a x, Hoare (fun s => P s[[x := a]]) (x <- a) P | Hoare_Seq : forall P Q R c1 c2, Hoare P c1 Q -> Hoare Q c2 R -> Hoare P (c1 ;; c2) R | Hoare_If : forall P Q b c1 c2, Hoare (fun s => P s /\ bval s b) c1 Q -> Hoare (fun s => P s /\ negb (bval s b)) c2 Q -> Hoare P (If b Then c1 Else c2) Q | Hoare_While : forall P b c, Hoare (fun s => P s /\ bval s b) c P -> Hoare P (While b Do c) (fun s => P s /\ negb (bval s b)) | Hoare_conseq: forall P P' Q Q' c, Hoare P c Q -> entails P' P -> entails Q Q' -> Hoare P' c Q'. Notation "|- {{ s | P }} c {{ s' | Q }}" := (Hoare (fun s => P) c (fun s' => Q)). Notation "|- {{ s | P }} c {{ Q }}" := (Hoare (fun s => P) c Q). Notation "|- {{ P }} c {{ s' | Q }}" := (Hoare P c (fun s' => Q)). Notation "|- {{ P }} c {{ Q }}" := (Hoare P c Q). Lemma lem_hoare_strengthen_pre : forall P P' Q c, entails P' P -> |- {{P}} c {{Q}} -> |- {{P'}} c {{Q}}. Proof. sauto unfold: entails. Qed. Lemma lem_hoare_weaken_post : forall P Q Q' c, entails Q Q' -> |- {{P}} c {{Q}} -> |- {{P}} c {{Q'}}. Proof. sauto unfold: entails. Qed. Lemma hoare_assign : forall (P Q : assn) x a, (forall s, P s -> Q s[[x := a]]) -> |- {{P}} x <- a {{Q}}. Proof. sauto use: lem_hoare_strengthen_pre unfold: entails. Qed. Lemma hoare_while : forall b (P Q: assn) c, |- {{s | P s /\ bval s b}} c {{P}} -> (forall s, P s /\ negb (bval s b) -> Q s) -> |- {{P}} (While b Do c) {{Q}}. Proof. sauto use: lem_hoare_weaken_post unfold: entails. Qed. (* Soundness of Hoare logic *) Theorem thm_hoare_correct : forall P Q c, |- {{P}} c {{Q}} -> |= {{P}} c {{Q}}. Proof. unfold HoareValid. induction 1. - sauto. - sauto. - sauto inv: BigStep. - sauto inv: BigStep. - intros *. remember (While b Do c). induction 1; qauto inv: BigStep. - sauto unfold: entails. Qed. (************************************************************************************) (* Insertion sort *) Require List. Import List.ListNotations. Open Scope list_scope. Inductive Sorted : list nat -> Prop := | Sorted_0 : Sorted [] | Sorted_1 : forall x, Sorted [x] | Sorted_2 : forall x y, x <= y -> forall l, Sorted (y :: l) -> Sorted (x :: y :: l). Fixpoint insert (l : list nat) (x : nat) : list nat := match l with | [] => [x] | h :: t => if x <=? h then x :: l else h :: insert t x end. Fixpoint isort (l : list nat) : list nat := match l with | [] => [] | h :: t => insert (isort t) h end. Lemma lem_insert_sorted_hlp : forall l y z, y <= z -> Sorted (y :: l) -> Sorted (y :: insert l z). Proof. induction l; qauto use: Sorted, Nat.lt_le_incl inv: Sorted. Qed. Lemma lem_insert_sorted (l : list nat) (x : nat) : Sorted l -> Sorted (insert l x). Proof. destruct l; hauto use: Sorted, lem_insert_sorted_hlp db: arith. Qed. Lemma lem_isort_sorted : forall l, Sorted (isort l). Proof. induction l; sauto use: lem_insert_sorted. Qed. Require Import Sorting.Permutation. Lemma lem_insert_perm : forall l x, Permutation (insert l x) (x :: l). Proof. induction l; sauto. Qed. Lemma lem_isort_perm : forall l, Permutation (isort l) l. Proof. induction l; sauto use: lem_insert_perm. Qed. Fixpoint sortedb (l : list nat) : bool := match l with | [] => true | [x] => true | x :: (y :: l') as t => (x <=? y) && sortedb t end. Lemma lem_sortedb_iff_sorted : forall l, sortedb l <-> Sorted l. Proof. induction l; sauto brefl: on. Qed. Lemma lem_insert_sortedb_hlp : forall l y z, y <= z -> sortedb (y :: l) -> sortedb (y :: insert l z). Proof. induction l; sauto brefl: on inv: - ctrs: - db: arith. Qed. Lemma lem_insert_sortedb : forall l x, sortedb l -> sortedb (insert l x). Proof. destruct l; hauto brefl: on use: lem_insert_sortedb_hlp db: arith. Qed. Lemma lem_isort_sortedb : forall l, sortedb (isort l). Proof. induction l; sauto use: lem_insert_sortedb. Qed. Inductive LeLst : nat -> list nat -> Prop := | LeLst_0 : forall n, LeLst n [] | LeLst_1 : forall n m l, n <= m -> LeLst n l -> LeLst n (m :: l). Lemma lem_lelst_insert : forall l n m, n <= m -> LeLst n l -> LeLst n (insert l m). Proof. induction l; sauto. Qed. Lemma lem_lelst_sorted : forall l x, Sorted (x :: l) <-> LeLst x l /\ Sorted l. Proof. induction l; sauto use: Nat.le_trans. Qed. Lemma lem_insert_sorted_2 : forall l x, Sorted l -> Sorted (insert l x). Proof. induction l as [|y l IH]. - sauto. - intros x H. simpl. destruct (Nat.leb_spec x y) as [H1|H1]. + constructor; assumption. + qauto use: lem_lelst_sorted, lem_lelst_insert, Nat.lt_le_incl. Qed. (* Tail-recursive reverse *) Fixpoint itrev {A} (lst acc : list A) := match lst with | [] => acc | h :: t => itrev t (h :: acc) end. Definition rev {A} (lst : list A) := itrev lst []. Lemma lem_itrev {A} : forall lst acc : list A, itrev lst acc = itrev lst [] ++ acc. Proof. induction lst as [| h t IH]. - auto. - assert (H: itrev t [h] = itrev t [] ++ [h]). { rewrite IH; reflexivity. } sauto db: slist. Qed. Lemma lem_rev_app {A} : forall l1 l2 : list A, rev (l1 ++ l2) = rev l2 ++ rev l1. Proof. unfold rev. induction l1; sauto use: @lem_itrev db: slist. Qed. Lemma lem_rev_rev {A} : forall l : list A, rev (rev l) = l. Proof. unfold rev. induction l as [| x l IH]. - reflexivity. - sauto use: (lem_itrev l [x]), (lem_rev_app (itrev l []) [x]). Qed. Lemma lem_rev_lst {A} : forall l : list A, rev l = List.rev l. Proof. unfold rev. induction l; sauto use: @lem_itrev. Qed. (* Permutations *) Lemma lem_perm_length {A} : forall l1 l2 : list A, Permutation l1 l2 -> List.length l1 = List.length l2. Proof. induction 1; sauto. Qed. Lemma lem_perm_sym {A} : forall l1 l2 : list A, Permutation l1 l2 -> Permutation l2 l1. Proof. induction 1; sauto. Qed. Lemma lem_perm_forall {A} (P : A -> Prop) : forall l1 l2, Permutation l1 l2 -> List.Forall P l1 -> List.Forall P l2. Proof. induction 1; sauto. Qed. (* Dependent types *) Inductive type := Nat | Bool. Inductive expr : type -> Type := | Var : nat -> expr Nat | Plus : expr Nat -> expr Nat -> expr Nat | Equal : expr Nat -> expr Nat -> expr Bool. Lemma lem_testdep : forall e : expr Nat, match e with Var n => n >= 0 | _ => e = e end. Proof. sauto dep: on. Qed. Require Import Program.Equality. Module DependentExpressions. Inductive type := Nat | Bool | Prod (ty1 ty2 : type). Fixpoint tyeval (ty : type) : Type := match ty with | Nat => nat | Bool => bool | Prod ty1 ty2 => tyeval ty1 * tyeval ty2 end. Inductive expr : type -> Type := | Var : nat -> expr Nat | Plus : expr Nat -> expr Nat -> expr Nat | Equal : expr Nat -> expr Nat -> expr Bool | Pair : forall {A B}, expr A -> expr B -> expr (Prod A B) | Fst : forall {A B}, expr (Prod A B) -> expr A | Snd : forall {A B}, expr (Prod A B) -> expr B | Const : forall A, tyeval A -> expr A | Ite : forall {A}, expr Bool -> expr A -> expr A -> expr A. Definition store := nat -> nat. Fixpoint eval {A} (s : store) (e : expr A) : tyeval A := match e with | Var n => s n | Plus e1 e2 => eval s e1 + eval s e2 | Equal e1 e2 => eval s e1 =? eval s e2 | Pair e1 e2 => (eval s e1, eval s e2) | Fst e => fst (eval s e) | Snd e => snd (eval s e) | Const _ c => c | Ite b e1 e2 => if eval s b then eval s e1 else eval s e2 end. Definition simp_plus (e1 e2 : expr Nat) := match e1, e2 with | Const Nat n1, Const Nat n2 => Const Nat (n1 + n2) | _, Const Nat 0 => e1 | Const Nat 0, _ => e2 | _, _ => Plus e1 e2 end. Lemma lem_plus : forall s e1 e2, eval s (simp_plus e1 e2) = eval s e1 + eval s e2. Proof. depind e1; sauto dep: on. Qed. Global Hint Rewrite lem_plus : simp_db. Definition simp_equal (e1 e2 : expr Nat) := match e1, e2 with | Const Nat n1, Const Nat n2 => Const Bool (n1 =? n2) | _, _ => Equal e1 e2 end. Lemma lem_equal : forall s e1 e2, eval s (simp_equal e1 e2) = (eval s e1 =? eval s e2). Proof. depind e1; sauto dep: on. Qed. Global Hint Rewrite lem_equal : simp_db. Definition unpair_type (T : type) := option (match T with Prod A B => expr A * expr B | _ => unit end). Definition unpair {A B : type} (e : expr (Prod A B)) : option (expr A * expr B) := match e in expr T return unpair_type T with | Pair e1 e2 => Some (e1, e2) | _ => None end. Definition simp_fst {A B : type} (e : expr (Prod A B)) : expr A := match unpair e with | Some (e1, e2) => e1 | None => Fst e end. Lemma lem_fst {A B} : forall s (e : expr (Prod A B)), eval s (simp_fst e) = fst (eval s e). Proof. depind e; sauto. Qed. Global Hint Rewrite @lem_fst : simp_db. Definition simp_snd {A B : type} (e : expr (Prod A B)) : expr B := match unpair e with | Some (e1, e2) => e2 | None => Snd e end. Lemma lem_snd {A B} : forall s (e : expr (Prod A B)), eval s (simp_snd e) = snd (eval s e). Proof. depind e; sauto. Qed. Global Hint Rewrite @lem_snd : simp_db. Definition simp_ite {A} (e : expr Bool) (e1 e2 : expr A) : expr A := match e with | Const Bool true => e1 | Const Bool false => e2 | _ => Ite e e1 e2 end. Lemma lem_ite {A} : forall s e (e1 e2 : expr A), eval s (simp_ite e e1 e2) = if eval s e then eval s e1 else eval s e2. Proof. depind e; sauto. Qed. Global Hint Rewrite @lem_ite : simp_db. Fixpoint simp {A} (e : expr A) : expr A := match e with | Var n => Var n | Plus e1 e2 => simp_plus (simp e1) (simp e2) | Equal e1 e2 => simp_equal (simp e1) (simp e2) | Pair e1 e2 => Pair (simp e1) (simp e2) | Fst e => simp_fst (simp e) | Snd e => simp_snd (simp e) | Const t c => Const t c | Ite e e1 e2 => simp_ite (simp e) (simp e1) (simp e2) end. Lemma lem_simp {A} : forall s (e : expr A), eval s (simp e) = eval s e. Proof. depind e; sauto db: simp_db. Qed. End DependentExpressions. Require Import Recdef. Require Import Program. Module MergeSort. Class DecTotalOrder (A : Type) := { leb : A -> A -> bool; leb_total_dec : forall x y, {leb x y}+{leb y x}; leb_antisym : forall x y, leb x y -> leb y x -> x = y; leb_trans : forall x y z, leb x y -> leb y z -> leb x z }. Arguments leb {A _}. Arguments leb_total_dec {A _}. Arguments leb_antisym {A _}. Arguments leb_trans {A _}. Global Instance dto_nat : DecTotalOrder nat. Proof. apply Build_DecTotalOrder with (leb := Nat.leb); induction x; sauto. Defined. Definition eq_dec {A} {dto : DecTotalOrder A} : forall x y : A, {x = y}+{x <> y}. intros x y. sdestruct (leb x y). - sdestruct (leb y x). + firstorder using leb_antisym. + sauto. - sdestruct (leb y x). + sauto. + destruct (leb_total_dec x y); auto. Defined. Function lexb {A} {dto : DecTotalOrder A} (l1 l2 : list A) : bool := match l1 with | [] => true | x :: l1' => match l2 with | [] => false | y :: l2' => if eq_dec x y then lexb l1' l2' else leb x y end end. Global Instance dto_list {A} {dto_a : DecTotalOrder A} : DecTotalOrder (list A). Proof. apply Build_DecTotalOrder with (leb := lexb). - induction x; sauto. - intros x y. functional induction (lexb x y). + sauto inv: list. + sauto. + sauto. + sauto inv: - use: leb_antisym. - intros x y. functional induction (lexb x y); sauto. Defined. Inductive Sorted {A} {dto : DecTotalOrder A} : list A -> Prop := | Sorted_0 : Sorted [] | Sorted_1 : forall x, Sorted [x] | Sorted_2 : forall x y l, Sorted (y :: l) -> leb x y -> Sorted (x :: y :: l). Lemma lem_sorted_tail {A} {dto : DecTotalOrder A} : forall l x, Sorted (x :: l) -> Sorted l. Proof. sauto. Qed. Definition LeLst {A} {dto : DecTotalOrder A} (x : A) := List.Forall (leb x). Lemma lem_lelst_trans {A} {dto : DecTotalOrder A} : forall l y, LeLst y l -> forall x, leb x y -> LeLst x l. Proof. induction 1; sauto. Qed. Lemma lem_lelst_sorted {A} {dto : DecTotalOrder A} : forall l x, Sorted (x :: l) <-> LeLst x l /\ Sorted l. Proof. induction l; sauto l: on use: lem_lelst_trans inv: Sorted, List.Forall ctrs: Sorted. Qed. Lemma lem_lelst_perm_rev {A} {dto : DecTotalOrder A} : forall l1 l2, Permutation l1 l2 -> forall x, LeLst x l2 -> LeLst x l1. Proof. induction 1; sauto inv: List.Forall ctrs: List.Forall. Qed. Lemma lem_lelst_app {A} {dto : DecTotalOrder A} : forall l1 l2 x, LeLst x l1 -> LeLst x l2 -> LeLst x (l1 ++ l2). Proof. induction 1; sauto. Qed. Global Hint Resolve lem_lelst_trans lem_lelst_perm_rev lem_lelst_app : lelst. Lemma lem_sorted_concat_1 {A} {dto : DecTotalOrder A} : forall (l l1 l2 : list A) x y, Permutation l (l1 ++ y :: l2) -> Sorted (x :: l1) -> leb x y -> Sorted (y :: l2) -> Sorted l -> Sorted (x :: l). Proof. intros. rewrite lem_lelst_sorted in *. sauto use: lem_lelst_trans, lem_lelst_perm_rev, lem_lelst_app inv: -. Qed. Lemma lem_lelst_nil {A} {dto : DecTotalOrder A} : forall x, LeLst x []. Proof. sauto. Qed. Lemma lem_lelst_cons {A} {dto : DecTotalOrder A} : forall x y l, LeLst x l -> leb x y -> LeLst x (y :: l). Proof. sauto. Qed. Global Hint Resolve lem_lelst_nil lem_lelst_cons : lelst. Lemma lem_sorted_concat_2 {A} {dto : DecTotalOrder A} : forall (l l1 l2 : list A) x y, Permutation l (x :: l1 ++ l2) -> Sorted (x :: l1) -> leb y x -> Sorted (y :: l2) -> Sorted l -> Sorted (y :: l). Proof. intros. rewrite lem_lelst_sorted in *. sauto db: lelst inv: -. Qed. Program Fixpoint merge {A} {dto : DecTotalOrder A} (l1 l2 : {l | Sorted l}) {measure (List.length l1 + List.length l2)} : {l | Sorted l /\ Permutation l (l1 ++ l2)} := match l1 with | [] => l2 | h1 :: t1 => match l2 with | [] => l1 | h2 :: t2 => if leb_total_dec h1 h2 then h1 :: merge t1 l2 else h2 :: merge l1 t2 end end. Next Obligation. sauto db: list. Qed. Next Obligation. eauto using lem_sorted_tail. Qed. Next Obligation. sauto use: lem_sorted_concat_1. Qed. Next Obligation. eauto using lem_sorted_tail. Qed. Next Obligation. simpl; lia. Qed. Next Obligation. split. - sauto use: lem_sorted_concat_2. - simpl_sigma. rewrite List.app_comm_cons. apply Permutation_cons_app. intuition. Qed. Program Fixpoint split {A} (l : list A) {measure (List.length l)} : { (l1, l2) : list A * list A | List.length l1 + List.length l2 = List.length l /\ List.length l1 <= List.length l2 + 1 /\ List.length l2 <= List.length l1 + 1 /\ Permutation l (l1 ++ l2) } := match l with | [] => ([], []) | [x] => ([x], []) | x :: y :: t => match split t with | (l1, l2) => (x :: l1, y :: l2) end end. Solve Obligations with sauto use: Permutation_cons_app. Lemma lem_split {A} : forall l : list A, 2 <= List.length l -> forall l1 l2, (l1, l2) = ` (split l) -> List.length l1 < List.length l /\ List.length l2 < List.length l. Proof. sauto. Qed. Ltac use_lem_split := match goal with | [ H: (?l1, ?l2) = ` (split ?l) |- _ ] => let Hl := fresh "H" in assert (Hl: 2 <= List.length l); [ destruct l as [|? [| ? ? ] ]; simpl | generalize (lem_split l Hl l1 l2) ]; hauto end. Obligation Tactic := idtac. Program Fixpoint mergesort {A} {dto : DecTotalOrder A} (l : list A) {measure (List.length l)} : {l' | Sorted l' /\ Permutation l' l} := match l with | [] => [] | [x] => [x] | _ => match split l with | (l1, l2) => merge (mergesort l1) (mergesort l2) end end. Next Obligation. sauto. Qed. Next Obligation. sauto. Qed. Next Obligation. program_simpl; use_lem_split. Qed. Next Obligation. sauto. Qed. Next Obligation. program_simpl; use_lem_split. Qed. Next Obligation. sauto. Qed. Next Obligation. split. - sauto. - qauto use: Permutation_app, Permutation_sym, perm_trans. Qed. Next Obligation. sauto. Qed. Next Obligation. program_simpl. Defined. End MergeSort. coqhammer-1.3.2-8.20/theories/000077500000000000000000000000001471571225200157065ustar00rootroot00000000000000coqhammer-1.3.2-8.20/theories/Plugin/000077500000000000000000000000001471571225200171445ustar00rootroot00000000000000coqhammer-1.3.2-8.20/theories/Plugin/Hammer.v000066400000000000000000000001131471571225200205370ustar00rootroot00000000000000From Hammer Require Export Tactics. Declare ML Module "coq-hammer.plugin". coqhammer-1.3.2-8.20/theories/Plugin/dune000066400000000000000000000002241471571225200200200ustar00rootroot00000000000000(coq.theory (name Hammer.Plugin) (package coq-hammer) (synopsis "CoqHammer Coq plugin") (theories Hammer.Tactics) (plugins coq-hammer.plugin)) coqhammer-1.3.2-8.20/theories/Tactics/000077500000000000000000000000001471571225200173005ustar00rootroot00000000000000coqhammer-1.3.2-8.20/theories/Tactics/Hints.v000066400000000000000000000110241471571225200205520ustar00rootroot00000000000000From Hammer Require Import Tactics. Require List Arith ZArith Bool. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_0_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_1_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.sub_0_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_0_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_1_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_assoc : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_assoc : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_add_distr_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_add_distr_l : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_sub_distr_r : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_sub_distr_l : shints. Global Hint Rewrite -> Arith.PeanoNat.Nat.sub_add_distr : shints. Global Hint Rewrite <- Arith.PeanoNat.Nat.leb_antisym : shints. Global Hint Rewrite <- Arith.PeanoNat.Nat.ltb_antisym : shints. Global Hint Rewrite -> ZArith.BinInt.Z.add_0_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.add_1_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.sub_0_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_0_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_1_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.add_assoc : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_assoc : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_add_distr_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_add_distr_l : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_sub_distr_r : shints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_sub_distr_l : shints. Global Hint Rewrite -> ZArith.BinInt.Z.sub_add_distr : shints. Global Hint Rewrite -> List.in_app_iff : shints. Global Hint Rewrite -> List.in_map_iff : shints. Global Hint Rewrite <- List.app_assoc : shints. Global Hint Rewrite -> Bool.orb_true_r : shints. Global Hint Rewrite -> Bool.orb_false_r : shints. Global Hint Rewrite -> Bool.andb_true_r : shints. Global Hint Rewrite -> Bool.andb_false_r : shints. Global Hint Rewrite -> Bool.orb_true_r : sbool. Global Hint Rewrite -> Bool.orb_true_l : sbool. Global Hint Rewrite -> Bool.orb_false_r : sbool. Global Hint Rewrite -> Bool.orb_false_l : sbool. Global Hint Rewrite -> Bool.andb_true_r : sbool. Global Hint Rewrite -> Bool.andb_true_l : sbool. Global Hint Rewrite -> Bool.andb_false_r : sbool. Global Hint Rewrite -> Bool.andb_false_l : sbool. Global Hint Rewrite -> List.app_nil_r : slist. Global Hint Rewrite -> List.rev_length : slist. Global Hint Rewrite -> List.app_length : slist. Global Hint Rewrite -> List.seq_length : slist. Global Hint Rewrite -> List.map_length : slist. Global Hint Rewrite -> List.map_length : slist. Global Hint Rewrite -> List.map_nth : slist. Global Hint Rewrite -> List.rev_unit : slist. Global Hint Rewrite -> List.rev_involutive : slist. Global Hint Rewrite -> List.in_app_iff : slist. Global Hint Rewrite -> List.in_map_iff : slist. Global Hint Rewrite <- List.app_assoc : slist. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_0_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_1_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.sub_0_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_0_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_1_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_assoc : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_assoc : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_add_distr_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_add_distr_l : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_sub_distr_r : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_sub_distr_l : sarith. Global Hint Rewrite -> Arith.PeanoNat.Nat.sub_add_distr : sarith. Global Hint Rewrite <- Arith.PeanoNat.Nat.leb_antisym : sarith. Global Hint Rewrite <- Arith.PeanoNat.Nat.ltb_antisym : sarith. Global Hint Rewrite -> ZArith.BinInt.Z.add_0_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.add_1_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.sub_0_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_0_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_1_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.add_assoc : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_assoc : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_add_distr_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_add_distr_l : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_sub_distr_r : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.mul_sub_distr_l : szarith. Global Hint Rewrite -> ZArith.BinInt.Z.sub_add_distr : szarith. coqhammer-1.3.2-8.20/theories/Tactics/Mathcomp.v000066400000000000000000000017421471571225200212430ustar00rootroot00000000000000From mathcomp Require Import ssreflect ssrbool ssrnat eqtype. From Hammer Require Import Reflect. Lemma ssrnat_eqn_eq : forall n m, eqn n m <-> n = m. Proof. split; move => /eqnP; auto. Qed. Lemma ssrnat_leq_le : forall n m, leq n m <-> le n m. Proof. split; move => /leP; auto. Qed. Lemma nat_eqop_eq : forall n m : nat, n == m <-> n = m. Proof. split; move => /eqP; auto. Qed. Hint Rewrite -> ssrnat_eqn_eq : brefl_hints. Hint Rewrite -> ssrnat_leq_le : brefl_hints. Hint Rewrite -> nat_eqop_eq : brefl_hints. (* TODO: Do we really want this? *) Lemma ssrnat_multE : forall x y, Nat.mul x y = x * y. Proof. rewrite multE. reflexivity. Qed. Lemma ssrnat_plusE : forall x y, Nat.add x y = x + y. Proof. rewrite plusE. reflexivity. Qed. Lemma ssrnat_minusE : forall x y, Nat.sub x y = x - y. Proof. rewrite minusE. reflexivity. Qed. Hint Rewrite <- ssrnat_multE : bsimpl_hints. Hint Rewrite <- ssrnat_plusE : bsimpl_hints. Hint Rewrite <- ssrnat_minusE : bsimpl_hints. coqhammer-1.3.2-8.20/theories/Tactics/Reconstr.v000066400000000000000000001354521471571225200213000ustar00rootroot00000000000000(* Coq v8.9 required *) (* author: Lukasz Czajka *) (* NOTE: This file is for backward compatibility only. It should not be used in new developments. *) (* This file contains backward compatibility reconstruction tactics for CoqHammer. *) (* This file may be distributed under the terms of the LGPL 2.1 license. *) (* Fragments of this file are based on the "crush" tactic of Adam Chlipala. *) Require List Arith ZArith Bool. Inductive ReconstrT : Set := Empty : ReconstrT | AllHyps : ReconstrT. Create HintDb yhints discriminated. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_0_r : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.sub_0_r : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_0_r : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_1_r : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.add_assoc : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_assoc : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_add_distr_r : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_add_distr_l : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_sub_distr_r : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.mul_sub_distr_l : yhints. Global Hint Rewrite -> Arith.PeanoNat.Nat.sub_add_distr : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.add_0_r : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.sub_0_r : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_0_r : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_1_r : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.add_assoc : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_assoc : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_add_distr_r : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_add_distr_l : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_sub_distr_r : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.mul_sub_distr_l : yhints. Global Hint Rewrite -> ZArith.BinInt.Z.sub_add_distr : yhints. Global Hint Rewrite -> List.in_app_iff : yhints. Global Hint Rewrite -> List.in_map_iff : yhints. Global Hint Rewrite -> List.in_inv : yhints. Global Hint Rewrite <- List.app_assoc : yhints. Global Hint Rewrite -> Bool.orb_true_r : yhints. Global Hint Rewrite -> Bool.orb_true_l : yhints. Global Hint Rewrite -> Bool.orb_false_r : yhints. Global Hint Rewrite -> Bool.orb_false_l : yhints. Global Hint Rewrite -> Bool.andb_true_r : yhints. Global Hint Rewrite -> Bool.andb_true_l : yhints. Global Hint Rewrite -> Bool.andb_false_r : yhints. Global Hint Rewrite -> Bool.andb_false_l : yhints. Ltac tyexact L := let tp := type of L in exact tp. Ltac getgoal := match goal with [ |- ?G ] => G end. Ltac notHyp P := match goal with | [ H : ?P1 |- _ ] => constr_eq P P1; fail 1 | _ => idtac end. Ltac isProp t := lazymatch type of t with | Prop => idtac end. Ltac notProp t := lazymatch type of t with | Prop => fail | _ => idtac end. Ltac checkListLen lst n := lazymatch n with | 0 => constr_eq lst Empty | S ?k => lazymatch lst with | (?t, ?h) => checkListLen t k | _ => idtac end end. Ltac noEvars t := tryif has_evar t then fail else idtac. Ltac natLe m n := let t := constr:(Nat.leb m n) in let b := (eval compute in t) in match b with | true => idtac end. (* TODO: `isAtom c' fails for a constant c *) Ltac isAtom t := lazymatch t with | ?A /\ ?B => fail | ?A \/ ?B => fail | exists x, _ => fail | _ _ => idtac | (_ /\ _) -> False => fail | (_ \/ _) -> False => fail | (exists x, _) -> False => fail | _ _ -> False => idtac | ?A -> False => is_var A | _ => is_var t end. Ltac isPropAtom t := isAtom t; isProp t. Ltac inList x lst := lazymatch lst with | (?t, ?y) => tryif constr_eq x y then idtac else inList x t | x => idtac | _ => fail end. Ltac notInList x lst := tryif inList x lst then fail else idtac. Ltac all f ls := match ls with | Empty => idtac | (?LS, ?X) => f X; all f LS | (_, _) => fail 1 | _ => f ls end. Ltac lst_rev lst := let rec hlp lst acc := match lst with | Empty => acc | (?t, ?h) => hlp t (acc, h) | ?x => constr:((acc, x)) end in hlp lst Empty. Ltac with_hyps p f := let rec hlp acc := match goal with | [ H : ?P |- _ ] => p P; notInList H acc; hlp (acc, H) | _ => f ltac:(lst_rev acc) end in hlp Empty. Ltac with_prop_hyps := with_hyps isProp. Ltac with_atom_hyps := with_hyps isAtom. Ltac all_hyps f := with_hyps ltac:(fun _ => idtac) ltac:(all f). Ltac all_prop_hyps f := with_prop_hyps ltac:(all f). Ltac all_atom_hyps f := with_atom_hyps ltac:(all f). Ltac countHyps inb := let rec hlp n := match goal with | [ H : _ |- _ ] => revert H; hlp (S n); intro H | _ => pose (inb := n) end in hlp 0. Ltac checkHypsNum n := let m := fresh "m" in countHyps m; let k := (eval unfold m in m) in natLe k n; clear m. Ltac yeasy := let rec use_hyp H := match type of H with | _ /\ _ => exact H || destruct_hyp H | _ => try solve [ inversion H ] end with do_intro := let H := fresh in intro H; use_hyp H with destruct_hyp H := case H; clear H; do_intro; do_intro in let rec use_hyps := match goal with | H : _ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps) | H : _ |- _ => solve [ inversion H ] | _ => idtac end in let do_atom := solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction ] in let rec do_ccl n := try do_atom; repeat (do_intro; try do_atom); lazymatch n with | O => fail | S ?k => solve [ split; do_ccl k ] end in solve [ do_atom | use_hyps; do_ccl 16 ] || fail "Cannot solve this goal". Ltac tryunfold x := let t := eval unfold x in x in lazymatch t with | _ _ => unfold x in * | (fun x => _ _) => unfold x in * | (fun x y => _ _) => unfold x in * | (fun x y z => _ _) => unfold x in * | (fun x y z u => _ _) => unfold x in * | (fun x y z u w => _ _) => unfold x in * | (fun x y z u w v => _ _) => unfold x in * | (forall s, _) => unfold x in * | (fun x => forall s, _) => unfold x in * | (fun x y => forall s, _) => unfold x in * | (fun x y z => forall s, _) => unfold x in * | (fun x y z u => forall s, _) => unfold x in * | (fun x y z u w => forall s, _) => unfold x in * | (fun x y z u w v => forall s, _) => unfold x in * | _ => idtac end. Ltac unfolding defs := repeat (autounfold with yhints; unfold iff in *; unfold not in *; all tryunfold defs). Ltac einst e := let tpe := type of e in match tpe with | forall x : ?T, _ => notProp T; let v := fresh "v" in evar (v : T); let v2 := eval unfold v in v in clear v; einst (e v2) | _ => generalize e end. Ltac einsting := all_prop_hyps ltac:(fun H => match type of H with | forall x : ?T, _ => notProp T; einst H; intro | _ => idtac end). Ltac mcongr tt := try solve [ hnf in *; congruence 8 ]. Ltac trysolve := eauto 2 with nocore yhints; try solve [ constructor ]; try subst; match goal with | [ |- ?t = ?u ] => mcongr tt | [ |- ?t <> ?u ] => mcongr tt | [ |- False ] => mcongr tt | _ => idtac end. Ltac msplit splt simp := simp tt; repeat (progress splt tt; simp tt). Ltac ydestruct t := lazymatch t with | _ _ => destruct t eqn:? | _ => tryif is_evar t then destruct t eqn:? else (is_var t; destruct t) end. Ltac yinversion H := inversion H; try subst; try clear H. Ltac xintro x := tryif intro x then idtac else let x1 := fresh x in intro x1. Ltac intro0 f := lazymatch goal with | [ |- forall x : ?T, _ ] => tryif isProp T then let H := fresh "H" in (tryif notHyp T then (intro H; try f H) else (intro H; try clear H)) else xintro x end. Ltac simp0 f H := let sintro tt := intro0 ltac:(simp0 f) in let tp := type of H in lazymatch tp with | (exists x, _) => elim H; clear H; xintro x; sintro tt | ?A = ?A => clear H | ?A -> ?A => clear H | ?A -> ?B = ?B => clear H | ?A /\ ?A => cut A; [ clear H; sintro tt | destruct H; assumption ] | ?A /\ ?B => elim H; clear H; sintro tt; sintro tt | ?A /\ ?B -> ?C => cut (A -> B -> C); [ clear H; sintro tt | intro; intro; apply H; split; assumption ] | ?A = ?A -> ?B => cut B; [ clear H; sintro tt | apply H; reflexivity ] | ?A -> ?A -> ?B => cut (A -> B); [ clear H; sintro tt | intro; apply H; assumption ] | ?A \/ ?A => cut A; [ clear H; sintro tt | elim H; intro; assumption ] | ?A \/ ?B -> ?C => cut (A -> C); [ cut (B -> C); [ clear H; sintro tt; sintro tt | intro; apply H; right; assumption ] | intro; apply H; left; assumption ] | Some _ = Some _ => injection H; try clear H | ?F ?X = ?F ?Y => (assert (X = Y); [ assumption | fail 1 ]) || (injection H; try clear H; match goal with | [ |- _ = _ -> _ ] => sintro tt; try subst end) | ?F ?X ?U = ?F ?Y ?V => (assert (X = Y); [ assumption | assert (U = V); [ assumption | fail 1 ] ]) || (injection H; try clear H; repeat match goal with | [ |- _ = _ -> _ ] => sintro tt; try subst end) | ?F ?X ?U ?A = ?F ?Y ?V ?B => (assert (X = Y); [ assumption | assert (U = V); [ assumption | assert (A = B); [ assumption | fail 1 ] ]]) || (injection H; try clear H; repeat match goal with | [ |- _ = _ -> _ ] => sintro tt; try subst end) | existT _ _ _ = existT _ _ _ => inversion H; try clear H | forall x : ?T1, ?A /\ ?B => cut (forall x : T1, A); [ cut (forall x : T1, B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2), ?A /\ ?B => cut (forall (x : T1) (y : T2), A); [ cut (forall (x : T1) (y : T2), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3), A); [ cut (forall (x : T1) (y : T2) (z : T3), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5) (w : ?T6), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5) (w : ?T6) (w1 : ?T7), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5) (w : ?T6) (w1 : ?T7) (w2 : ?T8), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7) (w2 : T8), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7) (w2 : T8), B); [ clear H; sintro tt; sintro tt | apply H ] | apply H ] | forall x : ?T1, ?A /\ ?B -> ?C => cut (forall x : T1, A -> B -> C); [ clear H; sintro tt | do 3 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2), A -> B -> C); [ clear H; sintro tt | do 4 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3), A -> B -> C); [ clear H; sintro tt | do 5 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4), A -> B -> C); [ clear H; sintro tt | do 6 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), A -> B -> C); [ clear H; sintro tt | do 7 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1), ?A \/ ?B -> ?C => cut (forall (x : T1), A -> C); [ cut (forall (x : T1), B -> C); [ clear H; sintro tt; sintro tt | do 2 intro; apply H with (x := x); right; assumption ] | do 2 intro; apply H with (x := x); left; assumption ] | forall (x : ?T1) (y : ?T2), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2), A -> C); [ cut (forall (x : T1) (y : T2), B -> C); [ clear H; sintro tt; sintro tt | do 3 intro; apply H with (x := x) (y := y); right; assumption ] | do 3 intro; apply H with (x := x) (y := y); left; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3), A -> C); [ cut (forall (x : T1) (y : T2) (z : T3), B -> C); [ clear H; sintro tt; sintro tt | do 4 intro; apply H with (x := x) (y := y) (z := z); right; assumption ] | do 4 intro; apply H with (x := x) (y := y) (z := z); left; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4), A -> C); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4), B -> C); [ clear H; sintro tt; sintro tt | do 5 intro; apply H with (x := x) (y := y) (z := z) (u := u); right; assumption ] | do 5 intro; apply H with (x := x) (y := y) (z := z) (u := u); left; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), A -> C); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), B -> C); [ clear H; sintro tt; sintro tt | do 6 intro; apply H with (x := x) (y := y) (z := z) (u := u) (v := v); right; assumption ] | do 6 intro; apply H with (x := x) (y := y) (z := z) (u := u) (v := v); left; assumption ] | ?A -> ?B => lazymatch goal with | [ H1 : A |- _ ] => isProp A; cut B; [ clear H; sintro tt | apply H; exact H1 ] | _ => f H end | _ => f H end. Ltac simp_hyp := simp0 ltac:(fun _ => fail). Ltac simp_hyps := unfold iff in *; unfold not in *; repeat match goal with | [ H1 : ?A, H2 : ?A -> ?B |- _ ] => assert B by (apply H2; exact H1); clear H2 | [ H : True |- _ ] => clear H | [ H : _ |- _ ] => simp_hyp H end. Ltac esimp_hyps := unfold iff in *; unfold not in *; repeat match goal with | [ H1 : ?A1, H2 : ?A2 -> ?B |- _ ] => unify A1 A2; notHyp B; assert B by (apply H2; exact H1); clear H2 | [ H : True |- _ ] => clear H | [ H : _ |- _ ] => simp_hyp H end. Ltac exsimpl := match goal with | [ H : forall (x : ?T1), exists a, _ |- _ ] => notProp T1; einst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2), exists a, _ |- _ ] => notProp T1; notProp T2; einst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3), exists a, _ |- _ ] => notProp T1; notProp T2; notProp T3; einst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), exists a, _ |- _ ] => notProp T1; notProp T2; notProp T3; notProp T4; einst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), exists a, _ |- _ ] => notProp T1; notProp T2; notProp T3; notProp T4; notProp T5; einst H; clear H; intro H; elim H; clear H; intro; intro end. Ltac isplit := match goal with | [ |- ?A /\ _ ] => assert A; [ idtac | split; [ assumption | idtac ] ] | [ H : _ \/ _ |- _ ] => elim H; clear H; intro | [ H : (?a +{ ?b }) |- _ ] => elim H; clear H; intro | [ H : ({ ?a }+{ ?b }) |- _ ] => elim H; clear H; intro | [ |- context[match ?X with _ => _ end] ] => ydestruct X | [ H : context[match ?X with _ => _ end] |- _ ] => ydestruct X | [ H : forall (x : ?T1), _ \/ _ |- _ ] => notProp T1; einst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2), _ \/ _ |- _ ] => notProp T1; notProp T2; einst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3), _ \/ _ |- _ ] => notProp T1; notProp T2; notProp T3; einst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), _ \/ _ |- _ ] => notProp T1; notProp T2; notProp T3; notProp T4; einst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), _ \/ _ |- _ ] => notProp T1; notProp T2; notProp T3; notProp T4; notProp T5; einst H; clear H; intro H; elim H; clear H end. Ltac eqsolve0 f := lazymatch goal with | [ |- ?A = ?A ] => reflexivity | [ |- ?A = ?B ] => solve [ unify A B; reflexivity | f tt ] end. Ltac rsolve0 tt := auto 2 with nocore yhints; try subst; mcongr tt; match goal with | [ |- ?A _ = ?A _ ] => apply f_equal; try eqsolve0 rsolve0 | [ |- ?A _ _ = ?A _ _ ] => apply f_equal2; try eqsolve0 rsolve0 | [ |- ?A _ _ _ = ?A _ _ _ ] => apply f_equal3; try eqsolve0 rsolve0 end. Ltac rsolve := msplit ltac:(fun _ => isplit) ltac:(fun _ => intros; simp_hyps; repeat exsimpl); rsolve0 tt. Ltac eqsolve2 tt := match goal with | [ |- ?A = ?A ] => reflexivity | [ |- ?A = ?B ] => unify A B; reflexivity | [ |- ?A _ = ?A _ ] => apply f_equal; eqsolve2 tt | [ |- ?A _ _ = ?A _ _ ] => apply f_equal2; eqsolve2 tt | [ |- ?A _ _ _ = ?A _ _ _ ] => apply f_equal3; eqsolve2 tt | [ |- ?A _ _ _ _ = ?A _ _ _ _ ] => apply f_equal4; eqsolve2 tt | [ |- ?A = ?B ] => solve [ rsolve ] end. Ltac eqsolve := eqsolve2 tt. Ltac isolve := let rec msolve splt simp := msplit splt simp; lazymatch goal with | [ H : False |- _ ] => exfalso; exact H | [ |- _ \/ _ ] => trysolve; try solve [ left; msolve splt simp | right; msolve splt simp ] | [ |- exists x, _ ] => trysolve; try solve [ eexists; msolve splt simp ] | _ => trysolve end in msolve ltac:(fun _ => isplit) ltac:(fun _ => intros; simp_hyps; repeat exsimpl). Ltac dsolve := match goal with | [ |- ?G ] => notProp G; auto with yhints; try solve [ repeat constructor ] | _ => auto with yhints; try yeasy end. Ltac yisolve := try solve [ unfold iff in *; unfold not in *; unshelve isolve; dsolve ]. Ltac yeqsolve := match goal with | [ |- _ = _ ] => solve [ unfold iff in *; unfold not in *; unshelve eqsolve; dsolve ] end. Ltac rchange tp := lazymatch goal with | [ |- tp ] => idtac | [ |- ?G1 = ?G2 ] => match tp with | ?tp1 = ?tp2 => let H1 := fresh "H" in let H2 := fresh "H" in assert (H1 : G1 = tp1) by eqsolve; assert (H2 : G2 = tp2) by eqsolve; try rewrite H1; clear H1; try rewrite H2; clear H2 | ?tp1 = ?tp2 => symmetry; let H1 := fresh "H" in let H2 := fresh "H" in assert (H1 : G1 = tp2) by eqsolve; assert (H2 : G2 = tp1) by eqsolve; try rewrite H1; clear H1; try rewrite H2; clear H2 end | [ |- ?G ] => let H := fresh "H" in assert (H : G = tp) by eqsolve; try rewrite H; clear H end. Ltac sintuition0 := simp_hyps; intuition (auto with nocore yhints); try subst; simp_hyps; try yeasy; mcongr tt; try solve [ constructor; auto with yhints ]; auto with yhints; try yeasy. Ltac sintuition := simp_hyps; try subst; cbn in *; sintuition0. Ltac eresolve H1 H2 := let H1i := fresh "H" in einst H1; intro H1i; let H2i := fresh "H" in einst H2; intro H2i; let T1 := type of H1i in let T2 := type of H2i in match T2 with | ?A -> ?B => unify T1 A; let e := fresh "H" in pose (e := H2i H1i); let tp := type of e in generalize e; clear e; notHyp tp; clear H1i; clear H2i | ?A1 = ?A2 -> ?B => unify T1 (A2 = A1); let e := fresh "H" in pose (e := H2i (eq_sym H1i)); let tp := type of e in generalize e; clear e; notHyp tp; clear H1i; clear H2i end. Ltac resolveGoal := repeat match goal with | [ H : ?A1 |- (?A2 -> ?B) -> _ ] => isPropAtom A1; unify A1 A2; let H0 := fresh "H" in intro H0; cut B; [ clear H0 | apply H0; exact H ] end. Ltac yrewrite H := (erewrite H by isolve) || (erewrite <- H by isolve). Ltac ysimp0 htrace f := simp0 ltac:(fun H => try (checkHypsNum 10; try (isPropAtom ltac:(type of H); yresolvewith0 htrace H); all_hyps ltac:(fun H0 => try (isPropAtom ltac:(type of H0); yresolve0 H0 H0 H)); f H)) with ysimp1 htrace := ysimp0 htrace ltac:(fun H => try match type of H with | _ = _ => yrewritingin0 (htrace, H) H end) with yintro0 htrace := intro0 ltac:(ysimp0 htrace ltac:(fun _ => idtac)) with yintro1 htrace := intro0 ltac:(ysimp1 htrace) with yresolve0 htrace H1 H2 := notInList H2 htrace; eresolve H1 H2; match goal with | [ |- (_ -> ?B1) -> ?B2 ] => unify B1 B2 | [ |- (_ -> _ -> ?B1) -> ?B2 ] => unify B1 B2 (* | [ |- (_ -> _ -> _ -> ?B1) -> ?B2 ] => unify B1 B2 *) | _ => idtac end; resolveGoal; match goal with | [ |- ?A -> _ ] => noEvars A end; yintro0 (htrace, H2) with yresolvewith0 htrace H1 := let A := type of H1 in repeat match goal with | [ H2 : A -> ?B |- _ ] => cut B; [ clear H2; yintro0 htrace | apply H2; exact H1 ] end; checkListLen htrace 2; all_prop_hyps ltac:(fun H2 => try yresolve0 (htrace, H1) H1 H2) with yrewritein0 htrace H H0 := notInList H0 htrace; let H1 := fresh "H" in einst H0; intro H1; isPropAtom ltac:(type of H1); (rewrite H in H1 by isolve) || (rewrite <- H in H1 by isolve); noEvars ltac:(type of H1); generalize H1; clear H1; yintro0 (htrace, H0) with yrewritingin0 htrace H := let rec hlp hyps n := lazymatch n with | 0 => idtac | S ?k => lazymatch hyps with | (?t, ?H0) => tryif yrewritein0 htrace H H0 then hlp t k else hlp t n | _ => idtac end end in with_prop_hyps ltac:(fun hyps => hlp hyps 4). Ltac ysimp := ysimp1 Empty. Ltac yintro := yintro1 Empty. Ltac yresolve := yresolve0 Empty. Ltac yresolvewith := yresolvewith0 Empty. Ltac yrewritein := yrewritein0 Empty. Ltac yintros0 acc := lazymatch goal with | [ |- forall x : ?T, _ ] => tryif isProp T then let H := fresh "H" in (tryif notHyp T then (intro H; yintros0 (acc, H)) else (intro H; try clear H)) else let x0 := fresh x in (intro x0; yintros0 (acc, x0)) | _ => all ltac:(fun H => try ysimp H) ltac:(lst_rev acc) end. Ltac yintros := yintros0 Empty. Ltac generalizing := repeat match goal with | [ H : _ |- _ ] => generalize H; clear H end. Ltac yinduction t := repeat match goal with | [ x : ?T |- _ ] => notProp T; tryif constr_eq x t then fail else (generalize x; clear x) end; induction t. Ltac ysplit := match goal with | [ |- ?A /\ _ ] => cut A; [ let H := fresh "H" in intro H; split; [ exact H | ysimp H ] | idtac ] | [ |- prod ?A _ ] => cut A; [ let H := fresh "H" in intro H; split; [ exact H | ysimp H ] | idtac ] | [ |- context[match ?X with _ => _ end] ] => ydestruct X | [ H : context[match ?X with _ => _ end] |- _ ] => ydestruct X end. Ltac yinvert H := solve [ inversion H ] || (inversion H; [idtac]; clear H; try subst). Ltac yinverting := repeat match goal with | [ H : ?P |- _ ] => isPropAtom P; lazymatch P with _ = _ => fail | _ => yinvert H end end. Ltac sauto_base0 := simp_hyps; try subst; cbn in *; simp_hyps; intuition (auto with yhints); simp_hyps; try subst; cbn in *; simp_hyps; try yeasy; try congruence 16; try solve [ constructor ]; yisolve. Ltac sauto_base := sauto_base0; repeat (progress autorewrite with yhints list in *; sauto_base0). Ltac sauto0 := sauto_base; repeat (progress ysplit; repeat ysplit; sauto_base). Ltac sauto1 := sauto0; repeat (progress yinverting; sauto0). Ltac sauto := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; sauto0; repeat (progress yinverting; sauto0). Definition rdone {T : Type} (x : T) := True. Ltac inster0 e trace := match type of e with | forall x : ?T, _ => match goal with | [ H : _ |- _ ] => inster0 (e H) (trace, H) | _ => isProp T; let H := fresh "H" in assert (H: T) by isolve; inster0 (e H) (trace, H) | _ => fail 2 end | _ => match trace with | (_, _) => match goal with | [ H : rdone (trace, _) |- _ ] => fail 1 | _ => let T := type of e in lazymatch type of T with | Prop => notHyp T; generalize e; intro; assert (rdone (trace, tt)) by constructor | _ => all ltac:(fun X => match goal with | [ H : rdone (_, X) |- _ ] => fail 1 | _ => idtac end) trace; let i := fresh "i" in pose (i := e); assert (rdone (trace, i)) by constructor end end end end. Ltac inster H := inster0 H H. Ltac un_done := repeat match goal with | [ H : rdone _ |- _ ] => clear H end. Ltac instering := all_prop_hyps ltac:(fun H => try inster H); un_done. Ltac ysplitting := repeat ysplit; let n := numgoals in guard n < 12; yisolve; let n := numgoals in guard n < 6. Ltac yunfold h := unfold h in *; ysplitting. Ltac yunfolding defs := let dounfold h := let h2 := eval unfold h in h in lazymatch h2 with | (match _ with _ => _ end) => try yunfold h | (fun x => match _ with _ => _ end) => try yunfold h | (fun x y => match _ with _ => _ end) => try yunfold h | (fun x y z => match _ with _ => _ end) => try yunfold h | (fun x y z u => match _ with _ => _ end) => try yunfold h | (fun x y z u v => match _ with _ => _ end) => try yunfold h | (fun x y z u v w => match _ with _ => _ end) => try yunfold h | _ => idtac end in all dounfold defs; unfolding defs. Ltac gunfolding defs := let dounfold h := lazymatch goal with | [ H : context[h] |- _ ] => idtac | _ => let h2 := eval unfold h in h in lazymatch h2 with | (match _ with _ => _ end) => try yunfold h | (fun x => match _ with _ => _ end) => try yunfold h | (fun x y => match _ with _ => _ end) => try yunfold h | (fun x y z => match _ with _ => _ end) => try yunfold h | (fun x y z u => match _ with _ => _ end) => try yunfold h | (fun x y z u v => match _ with _ => _ end) => try yunfold h | (fun x y z u v w => match _ with _ => _ end) => try yunfold h | _ => idtac end end in all dounfold defs; unfolding defs. Ltac rapply e := let tpe := type of e in lazymatch tpe with | forall x : ?T, _ => tryif isProp T then let H := fresh "H" in assert (H : T); [ idtac | rapply (e H) ] else let v := fresh "v" in evar (v : T); let v2 := eval unfold v in v in clear v; rapply (e v2) | _ => rchange tpe; exact e end. Ltac orinst H := let tpH := type of H in lazymatch tpH with | forall x : ?T, _ => tryif isProp T then let H0 := fresh "H" in assert (H0 : T); [ clear H | let H1 := fresh "H" in generalize (H H0); intro H1; clear H; clear H0; orinst H1 ] else let v := fresh "v" in evar (v : T); let v2 := eval unfold v in v in clear v; let H1 := fresh "H" in generalize (H v2); intro H1; clear H; orinst H1 | _ \/ _ => elim H; clear H; yintro end. Ltac yapply H := lazymatch goal with | [ H0 : context[_ = _] |- _ ] => rapply H | _ => simple eapply H end. Ltac yelles0 defs n rtrace gtrace := lazymatch n with | O => solve [ isolve ] | S ?k => let G := getgoal in notInList G gtrace; match goal with | [ H : False |- _ ] => exfalso; exact H | [ H : G |- _ ] => assumption | [ H : ?A = _ |- ?B = _ -> _ ] => unify A B; let H1 := fresh "H" in intro H1; rewrite H in H1; exfalso; congruence 0 | [ H : _ = ?A |- _ = ?B -> _ ] => unify A B; let H1 := fresh "H" in intro H1; rewrite H in H1; exfalso; congruence 0 | [ H : _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x, _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y, _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z, _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u, _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v, _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v w, _ -> False |- _ -> False ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : ?P |- ?P -> ?Q ] => (let H1 := fresh "H" in intro H1; try clear H1; move H at bottom; yelles0 defs n rtrace gtrace) || fail 1 | [ |- forall x, _ ] => doyelles defs n || fail 1 | [ |- _ /\ _ ] => doyelles defs n || fail 1 | [ |- context[match ?X with _ => _ end] ] => doyelles defs n || fail 1 | [ H : context[match ?X with _ => _ end] |- _ ] => doyelles defs n || fail 1 | [ |- exists x, _ ] => eexists; yelles0 defs n rtrace (gtrace, G) | [ |- { x & _ } ] => eexists; yelles0 defs n rtrace (gtrace, G) | [ |- { x | _ } ] => eexists; yelles0 defs n rtrace (gtrace, G) | [ H : forall x, G |- _ ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y, G |- _ ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z, G |- _ ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u, G |- _ ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v, G |- _ ] => simple eapply H; yelles0 defs k rtrace (gtrace, G) | [ H : _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x y, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ |- _ ] => solve [ isolve ] | [ |- _ ] => solve [ econstructor; cbn; yelles0 defs k rtrace (gtrace, G) ] | [ H : forall x y z u v, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v w, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v w p, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v w p p1, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v w p p1 p2, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z u v w p p1 p2 p3, _ _ |- _ _ ] => yapply H; yelles0 defs k rtrace (gtrace, G) | [ H : forall x y z, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x y z u, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x y z u v, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x y z u v w, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x y z u v w p, _ = _ |- _ ] => notInList H rtrace; yrewrite H; yelles0 defs k (rtrace, H) (gtrace, G) | [ H : forall x, exists e, _ |- _ ] => einst H; clear H; yintro; yelles0 defs k Empty Empty | [ H : forall x y, exists e, _ |- _ ] => einst H; clear H; yintro; yelles0 defs k Empty Empty | [ H : forall x y z, exists e, _ |- _ ] => einst H; clear H; yintro; yelles0 defs k Empty Empty | [ H : forall x y z u, exists e, _ |- _ ] => einst H; clear H; yintro; yelles0 defs k Empty Empty | [ H : forall x y z u v, exists e, _ |- _ ] => einst H; clear H; yintro; yelles0 defs k Empty Empty | [ H : forall x y z u v w, exists e, _ |- _ ] => einst H; clear H; yintro; yelles0 defs k Empty Empty | [ H : _ \/ _ |- _ ] => elim H; clear H; yintro; doyelles defs k | [ |- _ \/ _ ] => (left; yelles0 defs k rtrace (gtrace, G)) || (right; yelles0 defs k rtrace (gtrace, G)) | [ H : forall x, _ \/ _ |- _ ] => orinst H; yelles0 defs k Empty Empty | [ H : forall x y, _ \/ _ |- _ ] => orinst H; yelles0 defs k Empty Empty | [ H : forall x y z, _ \/ _ |- _ ] => orinst H; yelles0 defs k Empty Empty | [ H : forall x y z u, _ \/ _ |- _ ] => orinst H; yelles0 defs k Empty Empty | [ H : forall x y z u v, _ \/ _ |- _ ] => orinst H; yelles0 defs k Empty Empty | [ H : forall x y z u v w, _ \/ _ |- _ ] => orinst H; yelles0 defs k Empty Empty end end with doyelles defs n := yintros; repeat (cbn; try ysplit); lazymatch n with | 0 => solve [ isolve ] | S ?k => first [ yelles0 defs n Empty Empty | match goal with | [ x : ?T |- _ ] => notProp T; ydestruct x; unfolding defs; doyelles defs k | [ H : ?T |- _ ] => isPropAtom T; yinversion H; unfolding defs; doyelles defs k | [ |- ?A = ?B ] => progress (try ydestruct A; try ydestruct B); unfolding defs; yelles0 defs k Empty Empty | [ |- False ] => fail 1 | [ H : False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 | [ H : forall x, False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 | [ H : forall x y, False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 | [ H : forall x y z, False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 | [ H : forall x y z u, False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 | [ H : forall x y z u v, False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 | [ H : forall x y z u v w, False |- _ ] => (exfalso; yelles0 defs n Empty Empty) || fail 1 end ] end. Ltac yelles1 defs n := unfolding defs; repeat (yintros; repeat ysplit); doyelles defs n. Ltac yellesd defs n := cbn in *; unshelve yelles1 defs n; dsolve. Ltac yellesx n := cbn in *; unshelve yelles1 Empty n; dsolve. Ltac yelles n := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ yellesx n ]. Ltac yauto n := generalizing; yelles n. Ltac yrauto n := lazymatch n with | 0 => yellesx 1 | S ?k => match goal with | [ H : _ |- _ ] => rewrite H in * by isolve; simp_hyps; cbn in *; try subst; yisolve; yrauto k | _ => yellesx 1 end end. Ltac meauto f := intros; multimatch goal with | [ H : _ |- _ ] => simple eapply H; f tt | [ H : _ |- _ ] => (erewrite H + erewrite <- H); f tt end. Ltac meauto2 f := meauto ltac:(fun _ => meauto f). Ltac meauto3 f := meauto ltac:(fun _ => meauto2 f). Ltac ymeauto n := once meauto2 ltac:(fun _ => yellesx n). Ltac yreconstr1 lems defs := generalizing; repeat (yintros; repeat ysplit); try yellesd defs 4; try (progress yunfolding defs; yellesd defs 2); try yellesd defs 6; try ymeauto 1; try (progress yunfolding defs; yellesd defs 4); try yellesd defs 8; try ymeauto 3. Ltac yforward H := einst H; progress repeat match goal with | [ H0 : ?P |- (?Q -> _) -> _ ] => unify P Q; let H1 := fresh "H" in intro H1; generalize (H1 H0); clear H1 end; match goal with | [ |- ?P -> _ ] => noEvars P end; yintro. Ltac yforwarding := all_prop_hyps ltac:(fun H => try yforward H). Ltac forward_reasoning n := lazymatch n with | 0 => idtac | S ?k => yforwarding; forward_reasoning k end. Ltac iauto n := let rec doiauto n := lazymatch n with | 0 => solve [ eauto ] | S ?k => match goal with | [ H : ?T |- _ ] => isPropAtom T; yinversion H; cbn in *; doiauto k | _ => solve [ eauto ] end end in intros; doiauto n. Ltac docrush := sintuition; cbn in *; simp_hyps; forward_reasoning 2; simp_hyps; yisolve; try yellesx 1; try congruence; try match goal with | [ H : _ |- _ ] => rewrite H in * by isolve; simp_hyps; cbn in *; try subst; yellesx 1 end; try match goal with | [ H : ?T |- _ ] => isPropAtom T; yinversion H; cbn in *; try subst; simp_hyps; eauto with yhints; yellesx 1 end; try yellesx 2; try solve [ unshelve (intuition isolve; eauto 10 with yhints); dsolve ]; try ymeauto 0. Ltac ycrush1 := solve [ yisolve | eauto with yhints | docrush ]. Ltac ycrush := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; ycrush1. Ltac scrush0 := sauto1; forward_reasoning 2; sauto1; repeat instering; sauto1; try yellesx 1; try congruence; try match goal with | [ H : _ |- _ ] => rewrite H in * by isolve; simp_hyps; cbn in *; try subst; yellesx 1 end; try match goal with | [ H : ?T |- _ ] => isPropAtom T; yinversion H; cbn in *; try subst; simp_hyps; eauto with yhints; yellesx 1 end; try yellesx 2; try solve [ unshelve (intuition isolve; eauto 10 with yhints); dsolve ]; try ymeauto 0. Ltac scrush1 := solve [ yisolve | eauto with yhints | scrush0 ]. Ltac scrush := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; scrush1. Ltac bum := solve [ eauto with yhints | yrauto 1 ]. Ltac blast := sauto1; try bum; repeat instering; sauto1; try bum; repeat (progress (einsting; esimp_hyps); sauto1; try bum). Ltac hinit hyps lems defs := let rec pose_all ls acc := match ls with | Empty => idtac | (?LS, ?X) => generalize X; let H := fresh "H" in intro H; pose_all LS (acc, H) | (_, _) => fail 1 | _ => generalize ls; repeat match goal with | [ H : ?P |- _ ] => isProp P; notInList H acc; clear H end; intro end in tryif constr_eq hyps AllHyps then all ltac:(fun X => generalize X; let H := fresh "H" in intro H) lems else pose_all lems hyps; unfolding defs. Ltac htrivial hyps lems defs := hinit hyps lems defs; sintuition0. Ltac hobvious hyps lems defs := htrivial hyps lems defs; simp_hyps; yisolve; try yellesd defs 1. Ltac heasy hyps lems defs := hobvious hyps lems defs; try congruence; try solve [ unshelve (intuition isolve; eauto 10 with nocore yhints); dsolve ]. Ltac hsimple hyps lems defs := hobvious hyps lems defs; gunfolding defs; simp_hyps; try yellesd defs 2. Ltac hcrush hyps lems defs := unshelve (hinit hyps lems defs; try ycrush1); dsolve. Ltac hscrush hyps lems defs := hinit hyps lems defs; try scrush1. Ltac hyelles n hyps lems defs := hobvious hyps lems defs; try yellesd defs n. Ltac hrauto n hyps lems defs := htrivial hyps lems defs; try yrauto n. Ltac hblast hyps lems defs := hinit hyps lems defs; blast. Ltac hreconstr n hyps lems defs := hsimple hyps lems defs; generalizing; repeat (yintros; repeat ysplit); try yellesd defs n. Ltac hexhaustive n hyps lems defs := hsimple hyps lems defs; try ymeauto n. Ltac hyreconstr hyps lems defs := hsimple hyps lems defs; yreconstr1 lems defs. Ltac reasy lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve heasy AllHyps lems defs; dsolve ]. Ltac rsimple lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hsimple AllHyps lems defs; dsolve ]. Ltac rcrush lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hcrush AllHyps lems defs; dsolve ]. Ltac rscrush lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hscrush AllHyps lems defs; dsolve ]. Ltac rblast lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hblast AllHyps lems defs; dsolve ]. Ltac rreconstr4 lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hreconstr 4 AllHyps lems defs; dsolve ]. Ltac rreconstr6 lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hreconstr 6 AllHyps lems defs; dsolve ]. Ltac ryelles4 lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hyelles 4 AllHyps lems defs; dsolve ]. Ltac ryelles6 lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hyelles 6 AllHyps lems defs; dsolve ]. Ltac rrauto4 lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hrauto 4 AllHyps lems defs; dsolve ]. Ltac rexhaustive1 lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hexhaustive 1 AllHyps lems defs; dsolve ]. Ltac ryreconstr lems defs := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ unshelve hyreconstr AllHyps lems defs; dsolve ]. Ltac qrreasy := solve [ heasy AllHyps Empty Empty ]. Ltac qrrsimple := solve [ hsimple AllHyps Empty Empty ]. Ltac qrrcrush := solve [ hcrush AllHyps Empty Empty ]. Ltac qrrscrush := solve [ hscrush AllHyps Empty Empty ]. Ltac qrrblast := solve [ hblast AllHyps Empty Empty ]. Ltac qrrhreconstr4 := solve [ hreconstr 4 AllHyps Empty Empty ]. Ltac qrrhreconstr6 := solve [ hreconstr 6 AllHyps Empty Empty ]. Ltac qrryelles4 := solve [ hyelles 4 AllHyps Empty Empty ]. Ltac qrryelles6 := solve [ hyelles 6 AllHyps Empty Empty ]. Ltac qrrhrauto4 := solve [ hrauto 4 AllHyps Empty Empty ]. Ltac qrrexhaustive1 := solve [ hexhaustive 1 AllHyps Empty Empty ]. Ltac qrryreconstr := solve [ hyreconstr AllHyps Empty Empty ]. Ltac rreasy := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ heasy AllHyps Empty Empty ]. Ltac rrsimple := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hsimple AllHyps Empty Empty ]. Ltac rrcrush := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hcrush AllHyps Empty Empty ]. Ltac rrscrush := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hscrush AllHyps Empty Empty ]. Ltac rrblast := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hblast AllHyps Empty Empty ]. Ltac rrhreconstr4 := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hreconstr 4 AllHyps Empty Empty ]. Ltac rrhreconstr6 := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hreconstr 6 AllHyps Empty Empty ]. Ltac rryelles4 := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hyelles 4 AllHyps Empty Empty ]. Ltac rryelles6 := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hyelles 6 AllHyps Empty Empty ]. Ltac rrhrauto4 := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hrauto 4 AllHyps Empty Empty ]. Ltac rrexhaustive1 := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hexhaustive 1 AllHyps Empty Empty ]. Ltac rryreconstr := idtac "WARNING: legacy tactics from the Reconstr module are deprecated"; solve [ hyreconstr AllHyps Empty Empty ]. coqhammer-1.3.2-8.20/theories/Tactics/Reflect.v000066400000000000000000000230451471571225200210570ustar00rootroot00000000000000(* Boolean reflection tactics *) (* Authors: Burak Ekici, Lukasz Czajka *) Coercion is_true : bool >-> Sortclass. Require Export Bool. Require Import Setoid. Require Import Lia. Require Import BinInt BinNat PeanoNat. Require Import ssreflect ssrbool. (* bool *) Lemma andE : forall b1 b2, b1 && b2 <-> b1 /\ b2. Proof. split; move /andP; done. Qed. Lemma orE : forall b1 b2, b1 || b2 <-> b1 \/ b2. Proof. split; move /orP; done. Qed. Lemma negE : forall b, negb b <-> ~b. Proof. split; move /negP; done. Qed. Lemma implE : forall b1 b2, implb b1 b2 <-> (b1 -> b2). Proof. split; destruct b1, b2; intuition. Qed. Lemma iffE : forall b1 b2, eqb b1 b2 <-> (b1 <-> b2). Proof. split; destruct b1, b2; intuition. Qed. Lemma falseE : false <-> False. Proof. split; [ congruence | auto ]. Qed. Lemma trueE : true <-> True. Proof. split; auto. Qed. (* Z *) Lemma Z_eqb_eq: forall a b: Z, Z.eqb a b <-> a = b. Proof. intros; unfold is_true; now rewrite Z.eqb_eq. Qed. Lemma Z_gtb_gt: forall a b: Z, Z.gtb a b <-> Z.gt a b. Proof. split. - rewrite /is_true Z.gtb_lt. now apply Z.lt_gt. - rewrite /is_true Z.gtb_lt. now apply Z.gt_lt. Qed. Lemma Z_geb_ge: forall a b: Z, Z.geb a b <-> Z.ge a b. Proof. split. - rewrite /is_true Z.geb_le. now apply Z.le_ge. - rewrite /is_true Z.geb_le. now apply Z.ge_le. Qed. Lemma Z_ltb_lt: forall a b: Z, Z.ltb a b <-> Z.lt a b. Proof. split; now rewrite /is_true Z.ltb_lt. Qed. Lemma Z_leb_le: forall a b: Z, Z.leb a b <-> Z.le a b. Proof. split; now rewrite /is_true Z.leb_le. Qed. (* N *) Lemma N_eqb_eq: forall a b, N.eqb a b <-> a = b. Proof. intros; unfold is_true; now rewrite N.eqb_eq. Qed. Lemma N_ltb_lt: forall a b, N.ltb a b <-> N.lt a b. Proof. split; now rewrite /is_true N.ltb_lt. Qed. Lemma N_leb_le: forall a b, N.leb a b <-> N.le a b. Proof. split; now rewrite /is_true N.leb_le. Qed. Lemma N_gt_ltb: forall a b, N.gt a b <-> N.ltb b a. Proof. split; rewrite N_ltb_lt; lia. Qed. Lemma N_ge_leb: forall a b, N.ge a b <-> N.leb b a. Proof. split; rewrite N_leb_le; lia. Qed. (* nat *) Lemma Nat_eqb_eq: forall a b, Nat.eqb a b <-> a = b. Proof. intros; unfold is_true; now rewrite Nat.eqb_eq. Qed. Lemma Nat_ltb_lt: forall a b, Nat.ltb a b <-> a < b. Proof. split; now rewrite /is_true Nat.ltb_lt. Qed. Lemma Nat_leb_le: forall a b, Nat.leb a b <-> a <= b. Proof. split; now rewrite /is_true Nat.leb_le. Qed. Lemma Nat_gt_ltb: forall a b, a > b <-> Nat.ltb b a. Proof. split; rewrite Nat_ltb_lt; auto with arith. Qed. Lemma Nat_ge_leb: forall a b, a >= b <-> Nat.leb b a. Proof. split; rewrite Nat_leb_le; auto with arith. Qed. (* bool to Prop reflection *) Create HintDb brefl discriminated. Global Hint Rewrite -> andE : brefl. Global Hint Rewrite -> orE : brefl. Global Hint Rewrite -> negE : brefl. Global Hint Rewrite -> implE : brefl. Global Hint Rewrite -> iffE : brefl. Global Hint Rewrite -> falseE : brefl. Global Hint Rewrite -> trueE : brefl. Global Hint Rewrite -> Z_eqb_eq : brefl. Global Hint Rewrite -> Z_gtb_gt : brefl. Global Hint Rewrite -> Z_geb_ge : brefl. Global Hint Rewrite -> Z_ltb_lt : brefl. Global Hint Rewrite -> Z_leb_le : brefl. Global Hint Rewrite -> N_eqb_eq : brefl. Global Hint Rewrite -> N_ltb_lt : brefl. Global Hint Rewrite -> N_leb_le : brefl. Global Hint Rewrite -> Nat_eqb_eq : brefl. Global Hint Rewrite -> Nat_ltb_lt : brefl. Global Hint Rewrite -> Nat_leb_le : brefl. Tactic Notation "breflect" := try rewrite_strat topdown hints brefl. Tactic Notation "breflect" "in" hyp(H) := try rewrite_strat topdown hints brefl in H. Tactic Notation "breflect" "in" "*" := breflect; repeat match goal with | [H : _ |- _ ] => rewrite_strat topdown hints brefl in H end. (* Prop to bool reification *) Create HintDb breif discriminated. Global Hint Rewrite <- andE : breif. Global Hint Rewrite <- orE : breif. Global Hint Rewrite <- negE : breif. Global Hint Rewrite <- implE : breif. Global Hint Rewrite <- iffE : breif. Global Hint Rewrite <- falseE : breif. Global Hint Rewrite <- trueE : breif. Global Hint Rewrite <- Z_eqb_eq : breif. Global Hint Rewrite <- Z_gtb_gt : breif. Global Hint Rewrite <- Z_geb_ge : breif. Global Hint Rewrite <- Z_ltb_lt : breif. Global Hint Rewrite <- Z_leb_le : breif. Global Hint Rewrite <- N_eqb_eq : breif. Global Hint Rewrite <- N_ltb_lt : breif. Global Hint Rewrite <- N_leb_le : breif. Global Hint Rewrite -> N_gt_ltb : breif. Global Hint Rewrite -> N_ge_leb : breif. Global Hint Rewrite <- Nat_eqb_eq : breif. Global Hint Rewrite <- Nat_ltb_lt : breif. Global Hint Rewrite <- Nat_leb_le : breif. Global Hint Rewrite -> Nat_gt_ltb : breif. Global Hint Rewrite -> Nat_ge_leb : breif. Tactic Notation "breify" := try rewrite_strat topdown hints breif. Tactic Notation "breify" "in" hyp(H) := try rewrite_strat topdown hints breif in H. Tactic Notation "breify" "in" "*" := breify; repeat match goal with | [H : _ |- _ ] => rewrite_strat topdown hints breif in H end. (* Boolean simplification *) Create HintDb bsimpl discriminated. Global Hint Rewrite -> Bool.orb_true_r : bsimpl. Global Hint Rewrite -> Bool.orb_true_l : bsimpl. Global Hint Rewrite -> Bool.orb_false_r : bsimpl. Global Hint Rewrite -> Bool.orb_false_l : bsimpl. Global Hint Rewrite -> Bool.andb_true_r : bsimpl. Global Hint Rewrite -> Bool.andb_true_l : bsimpl. Global Hint Rewrite -> Bool.andb_false_r : bsimpl. Global Hint Rewrite -> Bool.andb_false_l : bsimpl. Global Hint Rewrite <- N.leb_antisym : bsimpl. Global Hint Rewrite <- N.ltb_antisym : bsimpl. Global Hint Rewrite <- Nat.leb_antisym : bsimpl. Global Hint Rewrite <- Nat.ltb_antisym : bsimpl. Tactic Notation "bsimpl" := try rewrite_strat topdown hints bsimpl. Tactic Notation "bsimpl" "in" hyp(H) := try rewrite_strat topdown hints bsimpl in H. Tactic Notation "bsimpl" "in" "*" := bsimpl; repeat match goal with | [H : _ |- _ ] => rewrite_strat topdown hints bsimpl in H end. (* hardcoded one-step reflection *) Tactic Notation "brefl" := lazymatch goal with | [ |- is_true (andb _ _) ] => rewrite -> andE | [ |- is_true (orb _ _) ] => rewrite -> orE | [ |- is_true (negb _) ] => rewrite -> negE | [ |- is_true (implb _ _) ] => rewrite -> implE | [ |- is_true (eqb _ _) ] => rewrite -> iffE | [ |- is_true true ] => rewrite -> trueE | [ |- is_true false ] => rewrite -> falseE | [ |- _ ] => fail "'brefl' failed. Did you mean 'breflect'?" end. Tactic Notation "brefl" "in" hyp(H) := lazymatch type of H with | is_true (andb _ _) => rewrite -> andE in H | is_true (orb _ _) => rewrite -> orE in H | is_true (negb _) => rewrite -> negE in H | is_true (implb _ _) => rewrite -> implE in H | is_true (eqb _ _) => rewrite -> iffE in H | is_true true => try clear H | is_true false => discriminate H | _ => fail "'brefl' failed. Did you mean 'breflect'?" end. Tactic Notation "breif" := lazymatch goal with | [ |- _ /\ _ ] => rewrite <- andE | [ |- _ \/ _ ] => rewrite <- orE | [ |- ~ _ ] => rewrite <- negE | [ |- _ -> _ ] => rewrite <- implE | [ |- _ <-> _ ] => rewrite <- iffE | [ |- True ] => rewrite <- trueE | [ |- False ] => rewrite <- falseE | [ |- _ ] => fail "'breif' failed. Did you mean 'breify'?" end. Tactic Notation "breif" "in" hyp(H) := lazymatch type of H with | _ /\ _ => rewrite <- andE in H | _ \/ _ => rewrite <- orE in H | ~ _ => rewrite <- negE in H | _ -> _ => rewrite <- implE in H | _ <-> _ => rewrite <- iffE in H | True => try clear H | False => destruct H | _ => fail "'breif' failed. Did you mean 'breify'?" end. (* boolean tactics *) Tactic Notation "bdestr" constr(b) "as" ident(H) := lazymatch type of b with | bool => destruct b eqn:H; [ replace (b = true) with (is_true b) in H by reflexivity | let H1 := fresh "H" in assert (H1: is_true (negb b)) by (rewrite H; simpl; constructor); clear H; rename H1 into H ] | _ => fail "not a boolean term" end. Tactic Notation "bdestr" constr(b) := let H := fresh "H" in bdestr b as H. Tactic Notation "bdestruct" constr(b) "as" ident(H) := lazymatch b with | Z.eqb ?b1 ?b2 => destruct (Z.eqb_spec b1 b2) as [H|H] | Z.gtb ?b1 ?b2 => destruct (Z.gtb_spec b1 b2) as [H|H] | Z.geb ?b1 ?b2 => destruct (Z.geb_spec b1 b2) as [H|H] | Z.ltb ?b1 ?b2 => destruct (Z.ltb_spec b1 b2) as [H|H] | Z.leb ?b1 ?b2 => destruct (Z.leb_spec b1 b2) as [H|H] | N.eqb ?b1 ?b2 => destruct (N.eqb_spec b1 b2) as [H|H] | N.leb ?b1 ?b2 => destruct (N.leb_spec b1 b2) as [H|H] | N.ltb ?b1 ?b2 => destruct (N.ltb_spec b1 b2) as [H|H] | Nat.eqb ?b1 ?b2 => destruct (Nat.eqb_spec b1 b2) as [H|H] | Nat.leb ?b1 ?b2 => destruct (Nat.leb_spec b1 b2) as [H|H] | Nat.ltb ?b1 ?b2 => destruct (Nat.ltb_spec b1 b2) as [H|H] | _ => bdestr b as H; bsimpl in H; breflect in H end. Tactic Notation "bdestruct" constr(b) := let H := fresh "H" in bdestruct b as H. Tactic Notation "binvert" constr(b) := lazymatch type of b with | is_true (andb _ _) => move /andP: b; let H := fresh "H" in intro H; destruct H | is_true (orb _ _) => move /orP: b; let H := fresh "H" in intro H; destruct H | is_true true => try clear b | is_true false => discriminate b | _ => fail end. Tactic Notation "binvert" constr(b) "as" simple_intropattern(pat) := lazymatch type of b with | is_true (andb _ _) => move /andP: b; intros pat | is_true (orb _ _) => move /orP: b; intros pat | is_true true => try clear b | is_true false => discriminate b | _ => fail end. Ltac bleft := apply /orP; left. Ltac bright := apply /orP; right. Ltac bsplit := apply /andP; split. Ltac blia := bsimpl in *; breflect in *; lia. Ltac bcongruence := breflect in *; congruence. coqhammer-1.3.2-8.20/theories/Tactics/Tactics.v000066400000000000000000001022331471571225200210620ustar00rootroot00000000000000(* Coq >= 8.9 required *) (* author: Lukasz Czajka *) (* This file contains the Ltac part of the automated reasoning tactics. *) (* This file may be distributed under the terms of the LGPL 2.1 license. *) Declare ML Module "coq-hammer-tactics.lib". Require Import Lia. Require Import Program.Equality. From Hammer Require Import Tactics.Reflect. Create HintDb shints discriminated. Ltac notHyp P := match goal with | [ H : ?P1 |- _ ] => constr_eq P P1; fail 1 | _ => idtac end. Ltac noteHyp P := match goal with | [ H : ?P1 |- _ ] => unify P P1; fail 1 | _ => idtac end. Ltac isProp t := lazymatch type of t with | Prop => idtac end. Ltac notProp t := tryif isProp t then fail else idtac. Ltac notTrivial P := lazymatch P with | True => fail | ?A = ?A => fail | ?A -> ?A => fail | ?A -> ?B = ?B => fail | _ => idtac end. Ltac noEvars t := tryif has_evar t then fail else idtac. Ltac seasy := let rec use_hyp H := match type of H with | _ /\ _ => exact H || destruct_hyp H | prod _ _ => exact H || destruct_hyp H | _ => try solve [ inversion H ] end with do_intro := let H := fresh in intro H; use_hyp H with destruct_hyp H := case H; clear H; do_intro; do_intro in let rec use_hyps := match goal with | H : _ /\ _ |- _ => exact H || (destruct_hyp H; use_hyps) | H : prod _ _ |- _ => exact H || (destruct_hyp H; use_hyps) | H : _ |- _ => solve [ inversion H ] | _ => idtac end in let do_atom := solve [ trivial with eq_true | reflexivity | symmetry; trivial | contradiction ] in let rec do_ccl n := try do_atom; repeat (do_intro; try do_atom); lazymatch n with | O => fail | S ?k => solve [ split; do_ccl k ] end in solve [ do_atom | use_hyps; do_ccl 16 ] || fail "Cannot solve this goal". Ltac fullunfold h := unfold h in *. Ltac fullunfold_all := repeat match goal with | [ |- context[?c] ] => unfold c in * | [ H: context[?c] |- _ ] => unfold c in * end. Ltac vinst e := let tpe := type of e in lazymatch tpe with | ?T -> ?Q => fail | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := eval unfold v in v in clear v; vinst (e v2) | _ => generalize e end. Ltac einst e := let tpe := type of e in lazymatch tpe with | ?T -> ?Q => generalize e | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := eval unfold v in v in clear v; einst (e v2) | _ => generalize e end. Ltac sdestruct t := lazymatch t with | _ _ => lazymatch type of t with | bool => bdestruct t | _ => destruct t eqn:? end | _ => tryif is_evar t then lazymatch type of t with | bool => bdestruct t | _ => destruct t eqn:? end else (is_var t; destruct t) end. Ltac dep_destruct t := let X := fresh "X" in let H := fresh "H" in remember t as X eqn:H; simpl in X; dependent destruction X; try rewrite <- H in *; try clear H. Ltac sdepdestruct t := sdestruct t || dep_destruct t. Ltac ssubst := try subst. Ltac subst_simpl := ssubst; simpl in *. Ltac xintro x := tryif intro x then idtac else let x1 := fresh x in intro x1. Ltac sintro := lazymatch goal with | [ |- ?T -> ?Q ] => let H := fresh "H" in (tryif notHyp T then (intro H; try simp_hyp H) else (intro H; try clear H)) | [ |- forall x : ?T, _ ] => xintro x end with simp_hyp H := let tp := type of H in lazymatch tp with | True => clear H | (exists x, _) => elim H; clear H; xintro x; sintro | { x & _ } => elim H; clear H; xintro x; sintro | { x | _ } => elim H; clear H; xintro x; sintro | ?A = ?A => clear H | ?A -> ?A => clear H | ?A -> ?B = ?B => clear H | ?A /\ ?A => cut A; [ clear H; sintro | destruct H; assumption ] | ?A /\ ?B => elim H; clear H; sintro; sintro | prod ?A ?B => let H1 := fresh H in let H2 := fresh H in destruct H as [ H1 H2 ]; try simp_hyp H1; try simp_hyp H2 | ?A /\ ?B -> ?C => cut (A -> B -> C); [ clear H; sintro | intro; intro; apply H; split; assumption ] | ?A = ?A -> ?B => cut B; [ clear H; sintro | apply H; reflexivity ] | ?A -> ?A -> ?B => cut (A -> B); [ clear H; sintro | intro; apply H; assumption ] | ?A \/ ?A => cut A; [ clear H; sintro | elim H; intro; assumption ] | ?A \/ ?B -> ?C => cut (A -> C); [ cut (B -> C); [ clear H; sintro; sintro | intro; apply H; right; assumption ] | intro; apply H; left; assumption ] | Some _ = Some _ => injection H; try clear H | ?F ?X = ?F ?Y => (assert (X = Y); [ assumption | fail 1 ]) || (injection H; try clear H; match goal with | [ |- _ = _ -> _ ] => sintro; ssubst end) | ?F ?X ?U = ?F ?Y ?V => (assert (X = Y); [ assumption | assert (U = V); [ assumption | fail 1 ] ]) || (injection H; try clear H; repeat match goal with | [ |- _ = _ -> _ ] => sintro; ssubst end) | ?F ?X ?U ?A = ?F ?Y ?V ?B => (assert (X = Y); [ assumption | assert (U = V); [ assumption | assert (A = B); [ assumption | fail 1 ] ]]) || (injection H; try clear H; repeat match goal with | [ |- _ = _ -> _ ] => sintro; ssubst end) | existT _ _ _ = existT _ _ _ => inversion_clear H | forall x : ?T1, ?A /\ ?B => cut (forall x : T1, A); [ cut (forall x : T1, B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2), ?A /\ ?B => cut (forall (x : T1) (y : T2), A); [ cut (forall (x : T1) (y : T2), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3), A); [ cut (forall (x : T1) (y : T2) (z : T3), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5) (w : ?T6), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5) (w : ?T6) (w1 : ?T7), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5) (w : ?T6) (w1 : ?T7) (w2 : ?T8), ?A /\ ?B => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7) (w2 : T8), A); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5) (w : T6) (w1 : T7) (w2 : T8), B); [ clear H; sintro; sintro | apply H ] | apply H ] | forall x : ?T1, ?A /\ ?B -> ?C => cut (forall x : T1, A -> B -> C); [ clear H; sintro | do 3 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2), A -> B -> C); [ clear H; sintro | do 4 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3), A -> B -> C); [ clear H; sintro | do 5 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4), A -> B -> C); [ clear H; sintro | do 6 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), ?A /\ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), A -> B -> C); [ clear H; sintro | do 7 intro; apply H; try assumption; split; assumption ] | forall (x : ?T1), ?A \/ ?B -> ?C => cut (forall (x : T1), A -> C); [ cut (forall (x : T1), B -> C); [ clear H; sintro; sintro | do 2 intro; apply H with (x := x); right; assumption ] | do 2 intro; apply H with (x := x); left; assumption ] | forall (x : ?T1) (y : ?T2), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2), A -> C); [ cut (forall (x : T1) (y : T2), B -> C); [ clear H; sintro; sintro | do 3 intro; apply H with (x := x) (y := y); right; assumption ] | do 3 intro; apply H with (x := x) (y := y); left; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3), A -> C); [ cut (forall (x : T1) (y : T2) (z : T3), B -> C); [ clear H; sintro; sintro | do 4 intro; apply H with (x := x) (y := y) (z := z); right; assumption ] | do 4 intro; apply H with (x := x) (y := y) (z := z); left; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4), A -> C); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4), B -> C); [ clear H; sintro; sintro | do 5 intro; apply H with (x := x) (y := y) (z := z) (u := u); right; assumption ] | do 5 intro; apply H with (x := x) (y := y) (z := z) (u := u); left; assumption ] | forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), ?A \/ ?B -> ?C => cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), A -> C); [ cut (forall (x : T1) (y : T2) (z : T3) (u : T4) (v : T5), B -> C); [ clear H; sintro; sintro | do 6 intro; apply H with (x := x) (y := y) (z := z) (u := u) (v := v); right; assumption ] | do 6 intro; apply H with (x := x) (y := y) (z := z) (u := u) (v := v); left; assumption ] | ?A -> ?B => lazymatch goal with | [ H1 : A |- _ ] => cut B; [ clear H; sintro | apply H; exact H1 ] end end. Ltac sintros := repeat match goal with [ |- ?G ] => isAtom G; fail 1 | [ |- _ ] => sintro end. Ltac intros_until_atom := repeat match goal with [ |- ?G ] => isAtom G; fail 1 | [ |- _ ] => intro end. Ltac simp_hyps := unfold iff in *; unfold not in *; repeat match goal with | [ H2 : ?A -> ?B, H1 : ?A |- _ ] => assert B by (apply H2; exact H1); clear H2 | [ H1 : ?P, H2 : ?P |- _ ] => isProp P; clear H2 || clear H1 | [ H : _ |- _ ] => simp_hyp H end. Ltac esimp_hyps := unfold iff in *; unfold not in *; repeat match goal with | [ H2 : ?A2 -> ?B, H1 : ?A1 |- _ ] => unify A1 A2; notHyp B; assert B by (apply H2; exact H1); clear H2 | [ H1 : ?P, H2 : ?P |- _ ] => isProp P; clear H2 || clear H1 | [ H : _ |- _ ] => simp_hyp H end. Ltac exsimpl := (* TODO: move to plugin *) match goal with | [ H : forall (x : ?T1), exists a, _ |- _ ] => vinst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2), exists a, _ |- _ ] => vinst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3), exists a, _ |- _ ] => vinst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), exists a, _ |- _ ] => vinst H; clear H; intro H; elim H; clear H; intro; intro | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), exists a, _ |- _ ] => vinst H; clear H; intro H; elim H; clear H; intro; intro end. Ltac isplit := (* TODO: move to plugin *) match goal with | [ |- ?A /\ _ ] => cut A; [ let H := fresh "H" in intro H; split; [ exact H | idtac ] | idtac ] | [ |- prod ?A _ ] => cut A; [ let H := fresh "H" in intro H; split; [ exact H | idtac ] | idtac ] | [ H : _ \/ _ |- _ ] => elim H; clear H; intro | [ H : (?a +{ ?b }) |- _ ] => elim H; clear H; intro | [ H : ({ ?a }+{ ?b }) |- _ ] => elim H; clear H; intro | [ H : (?a + ?b) |- _ ] => elim H; clear H; intro | [ H : forall (x : ?T1), _ \/ _ |- _ ] => vinst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2), _ \/ _ |- _ ] => vinst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3), _ \/ _ |- _ ] => vinst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4), _ \/ _ |- _ ] => vinst H; clear H; intro H; elim H; clear H | [ H : forall (x : ?T1) (y : ?T2) (z : ?T3) (u : ?T4) (v : ?T5), _ \/ _ |- _ ] => vinst H; clear H; intro H; elim H; clear H end. Ltac trysolve := eauto 2 with shints; try solve [ constructor ]; match goal with | [ |- ?t = ?u ] => try solve [ try subst; congruence 8 | match type of t with nat => lia | ZArith.BinInt.Z => lia end ] | [ |- ?t <> ?u ] => try solve [ try subst; congruence 8 | match type of t with nat => lia | ZArith.BinInt.Z => lia end ] | [ |- (?t = ?u) -> False ] => try solve [ intro; try subst; congruence 8 | match type of t with nat => lia | ZArith.BinInt.Z => lia end ] | [ |- False ] => try solve [ try subst; congruence 8 ] | [ |- ?t >= ?u ] => try solve [ lia ] | [ |- ?t <= ?u ] => try solve [ lia ] | [ |- ?t > ?u ] => try solve [ lia ] | [ |- ?t < ?u ] => try solve [ lia ] | _ => idtac end. Ltac trysolve_nolia := eauto 2 with shints; try solve [ constructor ]; match goal with | [ |- ?t = ?u ] => try solve [ try subst; congruence 8 ] | [ |- ?t <> ?u ] => try solve [ try subst; congruence 8 ] | [ |- (?t = ?u) -> False ] => try solve [ intro; try subst; congruence 8 ] | [ |- False ] => try solve [ try subst; congruence 8 ] | _ => idtac end. Ltac sfinal tac := let simp := intros; simp_hyps; repeat exsimpl in let rec msolve n := simp; repeat (progress isplit; guard numgoals < 20; simp); lazymatch goal with | [ H : False |- _ ] => elim H | _ => lazymatch n with | 0 => solve [ tac ] | S ?m => solve [ tac | left; msolve m | right; msolve m | eexists; msolve m ] (* TODO: move to plugin, generalize to applying non-recursive constructors *) end end in msolve 6. Ltac isolve := sfinal trysolve. Ltac isolve_nolia := sfinal trysolve_nolia. Ltac tryrsolve := let solver tac := lazymatch goal with | [ |- ?A = ?A ] => reflexivity | [ |- ?A = ?B ] => solve [ unify A B; reflexivity | tac ] end in auto 2 with shints; try subst; try congruence 16; match goal with | [ |- ?A _ = ?A _ ] => apply f_equal; try solver tryrsolve | [ |- ?A _ _ = ?A _ _ ] => apply f_equal2; try solver tryrsolve | [ |- ?A _ _ _ = ?A _ _ _ ] => apply f_equal3; try solver tryrsolve | [ |- ?A _ _ _ _ = ?A _ _ _ _ ] => apply f_equal4; try solver tryrsolve | [ |- ?A _ _ _ _ _ = ?A _ _ _ _ _ ] => apply f_equal5; try solver tryrsolve end. Ltac rsolve := let simp := intros; simp_hyps; repeat exsimpl in simp; repeat (progress isplit; guard numgoals < 10; simp); tryrsolve. Ltac eqsolve := match goal with | [ |- ?A = ?A ] => reflexivity | [ |- ?A = ?B ] => unify A B; reflexivity | [ |- ?A _ = ?A _ ] => apply f_equal; eqsolve | [ |- ?A _ _ = ?A _ _ ] => apply f_equal2; eqsolve | [ |- ?A _ _ _ = ?A _ _ _ ] => apply f_equal3; eqsolve | [ |- ?A _ _ _ _ = ?A _ _ _ _ ] => apply f_equal4; eqsolve | [ |- ?A _ _ _ _ _ = ?A _ _ _ _ _ ] => apply f_equal5; eqsolve | [ |- ?A = ?B ] => solve [ rsolve ] end. (* TODO: move eqsolve and rsolve to plugin *) Ltac rchange tp := lazymatch goal with | [ |- tp ] => idtac | [ |- ?G1 = ?G2 ] => match tp with | ?tp1 = ?tp2 => let H1 := fresh "H" in let H2 := fresh "H" in assert (H1 : G1 = tp1) by eqsolve; assert (H2 : G2 = tp2) by eqsolve; try rewrite H1; clear H1; try rewrite H2; clear H2 | ?tp1 = ?tp2 => symmetry; let H1 := fresh "H" in let H2 := fresh "H" in assert (H1 : G1 = tp2) by eqsolve; assert (H2 : G2 = tp1) by eqsolve; try rewrite H1; clear H1; try rewrite H2; clear H2 end | [ |- ?G ] => let H := fresh "H" in assert (H : G = tp) by eqsolve; try rewrite H; clear H end. Ltac sapply e := let tpe := type of e in lazymatch tpe with | ?T -> ?Q => let H := fresh "H" in assert (H : T); [ idtac | sapply (e H) ] | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := (eval unfold v in v) in clear v; sapply (e v2) | _ => rchange tpe; exact e end. Ltac dsolve := auto with shints; try seasy; try solve [ do 10 constructor ]. Ltac ssolve_gen tac := (intuition (auto with shints)); try solve [ tac ]; try congruence 24; try seasy; try solve [ econstructor; tac ]. Ltac ssolve := ssolve_gen isolve. Ltac ssolve_nolia := ssolve_gen isolve_nolia. Ltac leaf_solve := solve [ isolve ]. Ltac simpl_solve := solve [ isolve ]. Ltac leaf_solve_nolia := solve [ isolve_nolia ]. Ltac simpl_solve_nolia := solve [ isolve_nolia ]. Ltac bnat_reflect := repeat match goal with | [ H : true = false |- _ ] => inversion H | [ H : true = ?A |- _ ] => notHyp (A = true); assert (A = true) by (symmetry; exact H); clear H | [ H : false = ?A |- _ ] => notHyp (A = false); assert (A = false) by (symmetry; exact H); clear H | [ H : (Nat.eqb ?A ?B) = true |- _ ] => notHyp (A = B); assert (A = B) by (rewrite Coq.Arith.PeanoNat.Nat.eqb_eq in H; apply H); try subst | [ H : (Nat.eqb ?A ?B) = false |- _ ] => notHyp (A = B -> False); assert (A = B -> False) by (rewrite <- Coq.Arith.PeanoNat.Nat.eqb_eq; rewrite H; discriminate) | [ H : (Nat.leb ?A ?B) = true |- _ ] => notHyp (A <= B); assert (A <= B) by (apply Coq.Arith.Compare_dec.leb_complete; apply H) | [ H : (Nat.leb ?A ?B) = false |- _ ] => notHyp (B < A); assert (B < A) by (apply Coq.Arith.Compare_dec.leb_complete_conv; apply H) | [ H : (Nat.ltb ?A ?B) = true |- _ ] => notHyp (A < B); assert (A < B) by (apply Coq.Arith.PeanoNat.Nat.ltb_lt; apply H) | [ H : (Nat.ltb ?A ?B) = false |- _ ] => notHyp (B <= A); assert (B <= A) by (apply Coq.Arith.PeanoNat.Nat.ltb_ge; apply H) | [ H : (BinNat.N.eqb ?A ?B) = true |- _ ] => notHyp (A = B); assert (A = B) by (apply Coq.NArith.BinNat.N.eqb_eq; apply H); try subst | [ H : (BinNat.N.eqb ?A ?B) = false |- _ ] => notHyp (A = B -> False); assert (A = B -> False) by (rewrite <- Coq.NArith.BinNat.N.eqb_eq; rewrite H; discriminate) end. Ltac bool_reflect := bsimpl in *; breflect in *. Ltac invert_one_subgoal_nored_gen tac H := let ty := type of H in tac H; [idtac]; clear H; notHyp ty; ssubst. Ltac invert_one_subgoal_gen tac H := invert_one_subgoal_nored_gen tac H; simpl in *. Ltac invert H := inversion H. Ltac simple_invert H := solve [ inversion H ] || invert_one_subgoal_gen invert H. Ltac simple_invert_nored H := solve [ inversion H ] || invert_one_subgoal_nored_gen invert H. Ltac simple_invert_dep H := solve [ depelim H ] || invert_one_subgoal_gen depelim H. Ltac simple_invert_dep_nored H := solve [ depelim H ] || invert_one_subgoal_nored_gen depelim H. Ltac simple_inverting_gen tac := repeat match goal with | [ H : ?P |- _ ] => lazymatch P with | is_true _ => fail | _ => tac H end end. Ltac simple_inverting := simple_inverting_gen simple_invert. Ltac simple_inverting_nored := simple_inverting_gen simple_invert_nored. Ltac simple_inverting_dep := simple_inverting_gen simple_invert_dep. Ltac simple_inverting_dep_nored := simple_inverting_gen simple_invert_dep_nored. Ltac case_split := match goal with | [ |- context[match ?X with _ => _ end] ] => sdestruct X | [ H : context[match ?X with _ => _ end] |- _ ] => sdestruct X end. Ltac case_split_dep := match goal with | [ |- context[match ?X with _ => _ end] ] => sdepdestruct X | [ H : context[match ?X with _ => _ end] |- _ ] => sdepdestruct X end. Ltac case_splitting := repeat (case_split; ssubst; simpl in *). Ltac case_splitting_nored := repeat (case_split; ssubst). Ltac case_splitting_dep := repeat (case_split_dep; ssubst; simpl in *). Ltac case_splitting_dep_nored := repeat (case_split_dep; ssubst). Ltac case_split_concl := match goal with | [ |- context[match ?X with _ => _ end] ] => sdestruct X end. Ltac case_split_concl_dep := match goal with | [ |- context[match ?X with _ => _ end] ] => sdepdestruct X end. Ltac case_splitting_concl := repeat (case_split_concl; ssubst; simpl). Ltac case_splitting_concl_nored := repeat (case_split_concl; ssubst). Ltac case_splitting_concl_dep := repeat (case_split_concl_dep; ssubst; simpl). Ltac case_splitting_concl_dep_nored := repeat (case_split_concl_dep; ssubst). Ltac case_split_on_gen tac ind := match goal with | [ |- context[match ?X with _ => _ end] ] => tryif constr_eq ltac:(type of X) ind then tac X else fail | [ H : context[match ?X with _ => _ end] |- _ ] => tryif constr_eq ltac:(type of X) ind then tac X else fail end. Ltac case_split_on ind := case_split_on_gen sdestruct ind. Ltac case_split_on_dep ind := case_split_on_gen sdepdestruct ind. Ltac case_splitting_on t := repeat (case_split_on t; ssubst; simpl in *). Ltac case_splitting_on_nored t := repeat (case_split_on t; ssubst). Ltac case_splitting_on_dep t := repeat (case_split_on_dep t; ssubst; simpl in *). Ltac case_splitting_on_dep_nored t := repeat (case_split_on_dep t; ssubst). Ltac case_split_concl_on_gen tac ind := match goal with | [ |- context[match ?X with _ => _ end] ] => tryif constr_eq ltac:(type of X) ind then tac X else fail end. Ltac case_split_concl_on ind := case_split_concl_on_gen sdestruct ind. Ltac case_split_concl_on_dep ind := case_split_concl_on_gen sdepdestruct ind. Ltac case_splitting_concl_on t := repeat (case_split_concl_on t; ssubst; simpl). Ltac case_splitting_concl_on_nored t := repeat (case_split_concl_on t; ssubst). Ltac case_splitting_concl_on_dep t := repeat (case_split_concl_on_dep t; ssubst; simpl). Ltac case_splitting_concl_on_dep_nored t := repeat (case_split_concl_on_dep t; ssubst). Ltac generalizing := repeat match goal with | [ H : _ |- _ ] => generalize H; clear H end. Ltac fsolve := solve [ eassumption | symmetry; eassumption | econstructor ]. Ltac full_inst e tac := let tpe := type of e in lazymatch tpe with | ?T -> ?Q => cut T; [ let H := fresh "H" in intro H; full_inst (e H) tac; clear H | try fsolve ] | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := (eval unfold v in v) in clear v; full_inst (e v2) tac; try match goal with | [ y : T |- _ ] => unify y v2 end | _ => generalize e; tac tt; try fsolve end. Ltac sinv_gen dep H := lazymatch dep with | true => depelim H | false => inversion H end; ssubst. Ltac sdestr_gen dep H := let ty := type of H in tryif isIndexedInd ty then lazymatch dep with | true => depelim H | false => dependent inversion H end; ssubst else destruct H. Ltac sinvert_gen dep H := let intro_invert tt := let H1 := fresh "H" in intro H1; sinv_gen dep H1; try clear H1 in lazymatch type of H with | _ -> _ => full_inst H intro_invert | _ => lazymatch goal with | [ |- context[H] ] => sdestr_gen dep H | [ |- _ ] => let ty := type of H in sinv_gen dep H; tryif clear H then notHyp ty else idtac end end. Ltac sinvert H := sinvert_gen false H. Ltac sdepinvert H := sinvert_gen true H. Ltac full_einst e tac := let tpe := type of e in lazymatch tpe with | ?T -> ?Q => cut T; [ let H := fresh "H" in intro H; full_einst (e H) tac; clear H | try fsolve ] | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := (eval unfold v in v) in clear v; full_einst (e v2) tac | _ => generalize e; tac tt; try fsolve end. Ltac seinvert_gen dep H := let intro_invert tt := let H1 := fresh "H" in intro H1; sinv_gen dep H1; try clear H1 in lazymatch type of H with | _ -> _ => full_einst H intro_invert | _ => lazymatch goal with | [ |- context[H] ] => sdestr_gen dep H | [ |- _ ] => let ty := type of H in sinv_gen dep H; tryif clear H then noteHyp ty else idtac end end. Ltac seinvert H := seinvert_gen false H. Ltac sedepinvert H := seinvert_gen true H. Definition rdone {T : Type} (x : T) := True. Ltac un_done := repeat match goal with | [ H : rdone _ |- _ ] => clear H end. Ltac impl_fwd e := match type of e with | ?T -> ?Q => impl_fwd (e ltac:(fsolve)) | _ => generalize e end. Ltac forward_base tac e := lazymatch type of e with | ?P -> ?Q => fail | _ => let rec fwd e := lazymatch type of e with | ?P -> ?Q => impl_fwd (e (ltac:(fsolve))) | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := (eval unfold v in v) in clear v; fwd (e v2); try match goal with | [ y : T |- _ ] => unify y v2 end end in fwd e; tac; match goal with | [ |- ?P -> _ ] => notTrivial P; noEvars P; notHyp P; let H := fresh "H" in intro H; move H at top end end. Ltac forward H := forward_base ltac:(simpl) H. Ltac forward_nored H := forward_base ltac:(idtac) H. Ltac forwarding := repeat match goal with | [ H : forall x : _,_ |- _ ] => forward H end. Ltac forwarding_nored := repeat match goal with | [ H : forall x : _,_ |- _ ] => forward_nored H end. Ltac inList x lst := lazymatch lst with | (?t, ?y) => tryif constr_eq x y then idtac else inList x t | x => idtac | _ => fail end. Ltac notInList x lst := tryif inList x lst then fail else idtac. Ltac all f ls := match ls with | (?LS, ?X) => f X; all f LS | (_, _) => fail 1 | _ => f ls end. Ltac lst_rev lst := let rec hlp lst acc := match lst with | tt => acc | (?t, ?h) => hlp t (acc, h) | ?x => constr:((acc, x)) end in hlp lst tt. Ltac with_hyps p f := let rec hlp acc := match goal with | [ H : ?P |- _ ] => p P; notInList H acc; hlp (acc, H) | _ => f ltac:(lst_rev acc) end in hlp tt. Ltac with_prop_hyps := with_hyps isProp. Ltac all_hyps f := with_hyps ltac:(fun _ => idtac) ltac:(all f). Ltac all_prop_hyps f := with_prop_hyps ltac:(all f). Ltac qforward H := lazymatch type of H with | ?P -> ?Q => fail | _ => einst H; progress repeat match goal with | [ H0 : ?P |- (?Q -> _) -> _ ] => unify P Q; let H1 := fresh "H" in intro H1; generalize (H1 H0); clear H1 end; match goal with | [ |- ?P -> _ ] => notTrivial P; noEvars P; notHyp P end; intro end. Ltac qforwarding := all_hyps ltac:(fun H => try qforward H). Tactic Notation "forward_reasoning" int_or_var(n) := do n qforwarding. Ltac inster0 e trace := match type of e with | forall x : ?T, _ => match goal with | [ H : _ |- _ ] => inster0 (e H) (trace, H) | _ => isProp T; let H := fresh "H" in assert (H: T) by isolve; inster0 (e H) (trace, H) | _ => fail 2 end | _ => match trace with | (_, _) => match goal with | [ H : rdone (trace, _) |- _ ] => fail 1 | _ => let T := type of e in lazymatch type of T with | Prop => notHyp T; generalize e; intro; assert (rdone (trace, tt)) by constructor | _ => all ltac:(fun X => match goal with | [ H : rdone (_, X) |- _ ] => fail 1 | _ => idtac end) trace; let i := fresh "i" in pose (i := e); assert (rdone (trace, i)) by constructor end end end end. Ltac inster H := inster0 H H. Ltac instering := repeat match goal with | [ H : ?T |- _ ] => isProp T; inster H end; un_done. Ltac einster e := let tpe := type of e in lazymatch tpe with | ?T -> ?Q => let H := fresh "H" in tryif (assert (H : T) by isolve) then einster (e H); clear H else noteHyp tpe; generalize e; intro | forall x : ?T, _ => let v := fresh "v" in evar (v : T); let v2 := (eval unfold v in v) in clear v; einster (e v2) | _ => noteHyp tpe; generalize e; intro end. Ltac einstering := repeat match goal with | [ H : ?P |- _ ] => isProp P; einster H end. Ltac srewrite H := (erewrite H in * by isolve_nolia) || (erewrite <- H in * by isolve_nolia). Ltac srewrite_in_concl H := (erewrite H by isolve_nolia) || (erewrite <- H by isolve_nolia). Ltac srewriting := repeat match goal with | [ H : ?T |- _ ] => checkTargetLPO T; erewrite H in * by isolve_nolia | [ H : ?T |- _ ] => checkTargetRevLPO T; erewrite <- H in * by isolve_nolia end. Ltac red_in_all := simpl in *. Ltac red_in_concl := simpl. Ltac destruct_sigma_in_goal := repeat match goal with | [ |- context[proj1_sig ?X] ] => destruct X; simpl end. Ltac destruct_sigma := repeat match goal with | [H : context[proj1_sig ?X] |- _] => destruct X; simpl in * | [ |- context[proj1_sig ?X] ] => destruct X; simpl in * end. Ltac destruct_sigma_dep_in_goal := repeat match goal with | [ |- context[proj1_sig ?X] ] => dep_destruct X; simpl end. Ltac destruct_sigma_dep := repeat match goal with | [H : context[proj1_sig ?X] |- _] => dep_destruct X; simpl in * | [ |- context[proj1_sig ?X] ] => dep_destruct X; simpl in * end. Ltac invert_sigma := repeat match goal with | [ H: exist _ _ _ = exist _ _ _ |- _ ] => induction H using eq_sig_rect; ssubst; simpl in * | [ H: existT _ _ _ = existT _ _ _ |- _ ] => induction H using eq_sigT_rect; ssubst; simpl in * end. Ltac simpl_sigma := invert_sigma; destruct_sigma. Ltac unfold_local_defs := repeat match goal with | [f := _ |- _] => unfold f in *; try clear f end. Ltac generalize_proofs_in t := lazymatch t with | ?X ?Y => (tryif is_var Y then idtac else let ty := type of Y in lazymatch type of ty with | Prop => try generalize Y | _ => generalize_proofs_in Y end); generalize_proofs_in X | ?X -> ?Y => generalize_proofs_in X; generalize_proofs_in Y | _ => idtac end. Ltac generalize_proofs_in_goal := match goal with | [|- ?G] => generalize_proofs_in G end. Ltac generalize_proofs_in_hyp H := let T := type of H in try (revert H; progress generalize_proofs_in T). Ltac generalize_proofs := generalize_proofs_in_goal; repeat match goal with | [H: ?T |- _] => revert H; progress generalize_proofs_in T end. Tactic Notation "generalize" "proofs" := generalize_proofs_in_goal. Tactic Notation "generalize" "proofs" "in" ident(H) := generalize_proofs_in_hyp H. Tactic Notation "generalize" "proofs" "in" "*" := generalize_proofs. Ltac use_tac := let H := fresh "H" in intro H; try move H at top; try simp_hyp H. Ltac congr_tac := congruence 400. Ltac lia_tac := lia. Ltac f_equal_tac := f_equal. Ltac firstorder_tac := solve [ firstorder (trysolve; auto) ]. Ltac firstorder_nolia_tac := solve [ firstorder (trysolve_nolia; auto) ]. Declare ML Module "coq-hammer-tactics.plugin". Ltac sauto_tac := sauto. Ltac sdone_tac := solve [ trysolve ]. Ltac sdone_nolia_tac := solve [ trysolve_nolia ]. Tactic Notation "sdone" := sdone_tac. Tactic Notation "sdone" "lia:" "on" := sdone_tac. Tactic Notation "sdone" "lia:" "off" := sdone_nolia_tac. coqhammer-1.3.2-8.20/theories/Tactics/dune000066400000000000000000000003021471571225200201510ustar00rootroot00000000000000(coq.theory (name Hammer.Tactics) (package coq-hammer-tactics) (synopsis "CoqHammer Coq tactics") (modules :standard \ Mathcomp) (plugins coq-hammer-tactics.lib coq-hammer-tactics.plugin))